DBIx-Class-Tree-0.03003/0000755000175000017500000000000011516075343014550 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/inc/0000755000175000017500000000000011516075343015321 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/inc/Module/0000755000175000017500000000000011516075343016546 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/inc/Module/Install.pm0000644000175000017500000003013511516075252020513 0ustar ahartmaiahartmai#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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } 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::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; 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 //, $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. DBIx-Class-Tree-0.03003/inc/Module/Install/0000755000175000017500000000000011516075343020154 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/inc/Module/Install/Fetch.pm0000644000175000017500000000462711516075253021554 0ustar ahartmaiahartmai#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; DBIx-Class-Tree-0.03003/inc/Module/Install/ReadmeFromPod.pm0000644000175000017500000000162411516075252023200 0ustar ahartmaiahartmai#line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.12'; sub readme_from { my $self = shift; return unless $self->is_admin; my $file = shift || $self->_all_from or die "Can't determine file to make readme_from"; my $clean = shift; print "Writing README from $file\n"; require Pod::Text; my $parser = Pod::Text->new(); open README, '> README' or die "$!\n"; $parser->output_fh( *README ); $parser->parse_file( $file ); if ($clean) { $self->clean_files('README'); } return 1; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 112 DBIx-Class-Tree-0.03003/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611516075253022245 0ustar ahartmaiahartmai#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; DBIx-Class-Tree-0.03003/inc/Module/Install/Win32.pm0000644000175000017500000000340311516075253021414 0ustar ahartmaiahartmai#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; DBIx-Class-Tree-0.03003/inc/Module/Install/Metadata.pm0000644000175000017500000004302011516075252022230 0ustar ahartmaiahartmai#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; DBIx-Class-Tree-0.03003/inc/Module/Install/Can.pm0000644000175000017500000000333311516075253021215 0ustar ahartmaiahartmai#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 DBIx-Class-Tree-0.03003/inc/Module/Install/Makefile.pm0000644000175000017500000002703211516075252022232 0ustar ahartmaiahartmai#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 DBIx-Class-Tree-0.03003/inc/Module/Install/Base.pm0000644000175000017500000000214711516075252021367 0ustar ahartmaiahartmai#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 DBIx-Class-Tree-0.03003/README0000644000175000017500000000341511516075253015433 0ustar ahartmaiahartmaiNAME DBIx::Class::Tree - Manipulate and anaylze tree structured data. GETTING HELP/SUPPORT The community can be found via: * IRC: irc.perl.org#dbix-class * Mailing list: * RT Bug Tracker: * gitweb: * git: DESCRIPTION The tree modules provide the tools to represent, modify, and analyze trees of data with DBIx::Class. COMPONENTS DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. DBIx::Class::Tree::AdjacencyList::Ordered - Glue DBIx::Class::Ordered and DBIx::Class::Tree::AdjacencyList together. DAG All tree related modules must conform to have and use the basic traversal methods of a DAG. For the most part this just means that Tree modules must provide the appearance of having multiple parents per node (via a parents() method) but may very well never return more than one parent. All utility modules, such as a Visitor module, should do its best to never assume that a node only has one parent. There are situations where this is not possible - in those cases the module's documentation should clearly state that it is not compatible with DAGs. So far there is no Tree::DAG module, but there will be. These requirements are vague, and the requirements of Tree modules to be DAG compatible will become more defined in due course. AUTHOR Aran Clary Deltac LICENSE You may distribute this code under the same terms as Perl itself. DBIx-Class-Tree-0.03003/TODO0000644000175000017500000000063311510371717015240 0ustar ahartmaiahartmai - Support DAGs. - Tree::Visitor - Come up with a better name for attach_before and attach_after. - Support multiple columns for ordering. - Declare both the parent column and the position column in one call. - Add an ancestors() and descendants() method with support for resultset cacheing. - Not all methods are covered by the tests. - has_ancestor() method. - DBIx::Class::Tree::NestedSet DBIx-Class-Tree-0.03003/Changes0000644000175000017500000000323311516040307016034 0ustar ahartmaiahartmai Revision history for DBIx::Class::Tree 0.03003 2011-01-20 - The repository has been migrated from subversion to git - Optimized is_leaf to not trigger another query if the children releationship is prefetched 0.03002 2010-09-23 - Added various docs - Added ordered ancesors (nebulous) 0.03001 2010-04-25 - Fixed the parents (note the plural) relationship to not have cascade_copy set by default 0.03000 2009-08-18 - Removed EXPERIMENTAL flags, because after 2 years there'd be bugs if there were any serious problems. (Ian Wells) - Fix borked tests (DBIx-Class 0.081 got rid of the loophole they used) (ribasushi) - Increase DBIC dependency to 0.08100. (bluefeet) 0.02001 2007-12-16 - Remove invalid line. 0.02000 2007-10-29 - Use Module::Install instead of Module::Build. - Fixed is_leaf, is_branch, and is_root. - Renamed set_primary_ley as set_primary_key. - New has_descdendant() method. - New repair_tree flag. - parent() now repairs the tree if needed/allowed. - Do not cascade delete via the parents() relationship. 0.01000 2006-11-06 - Added is_leaf, is_root, and is_branch to AdjacencyList. - Added a validation override for set_primary_key(). - Removed the _grouping_clause override method. - Created a TODO document. - attach_child() attach_sibling() now accept more than one object to attach. - Added tests for Ordered. - Renamed Positional as Ordered. - Added tests for AdjacencyList. - Moved Positional functionality out of AdjacencyList and in to AdjacencyList::Positional. - AdjacencyList module created. - First version. DBIx-Class-Tree-0.03003/lib/0000755000175000017500000000000011516075343015316 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/lib/DBIx/0000755000175000017500000000000011516075343016104 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/lib/DBIx/Class/0000755000175000017500000000000011516075343017151 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/lib/DBIx/Class/Tree.pm0000644000175000017500000000376411516040240020404 0ustar ahartmaiahartmaipackage DBIx::Class::Tree; # vim: ts=8:sw=4:sts=4:et use strict; use warnings; use base qw( DBIx::Class ); our $VERSION = '0.03003'; 1; __END__ =head1 NAME DBIx::Class::Tree - Manipulate and anaylze tree structured data. =head1 GETTING HELP/SUPPORT The community can be found via: =over =item * IRC: irc.perl.org#dbix-class =for html (click for instant chatroom login) =item * Mailing list: L =item * RT Bug Tracker: L =item * gitweb: L =item * git: L =back =head1 DESCRIPTION The tree modules provide the tools to represent, modify, and analyze trees of data with DBIx::Class. =head1 COMPONENTS L - Manage a tree of data using the common adjacency list model. L - Glue DBIx::Class::Ordered and DBIx::Class::Tree::AdjacencyList together. =head1 DAG All tree related modules must conform to have and use the basic traversal methods of a DAG. For the most part this just means that Tree modules must provide the appearance of having multiple parents per node (via a parents() method) but may very well never return more than one parent. All utility modules, such as a Visitor module, should do its best to never assume that a node only has one parent. There are situations where this is not possible - in those cases the module's documentation should clearly state that it is not compatible with DAGs. So far there is no Tree::DAG module, but there will be. These requirements are vague, and the requirements of Tree modules to be DAG compatible will become more defined in due course. =head1 AUTHOR Aran Clary Deltac =head1 LICENSE You may distribute this code under the same terms as Perl itself. DBIx-Class-Tree-0.03003/lib/DBIx/Class/Tree/0000755000175000017500000000000011516075343020050 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/lib/DBIx/Class/Tree/AdjacencyList/0000755000175000017500000000000011516075343022565 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/lib/DBIx/Class/Tree/AdjacencyList/Ordered.pm0000644000175000017500000001462211510371717024512 0ustar ahartmaiahartmaipackage DBIx::Class::Tree::AdjacencyList::Ordered; # vim: ts=8:sw=4:sts=4:et use strict; use warnings; use base qw( DBIx::Class ); use Carp qw( croak ); __PACKAGE__->load_components(qw( Ordered Tree::AdjacencyList )); =head1 NAME DBIx::Class::Tree::AdjacencyList::Ordered - Glue DBIx::Class::Ordered and DBIx::Class::Tree::AdjacencyList together. =head1 SYNOPSIS Create a table for your tree data. CREATE TABLE items ( item_id INTEGER PRIMARY KEY AUTOINCREMENT, parent_id INTEGER NOT NULL DEFAULT 0, position INTEGER NOT NULL, name TEXT NOT NULL ); In your Schema or DB class add Tree::AdjacencyList::Ordered to the front of the component list. __PACKAGE__->load_components(qw( Tree::AdjacencyList::Ordered ... )); Specify the column that contains the parent ID and position of each row. package My::Employee; __PACKAGE__->position_column('position'); __PACKAGE__->parent_column('parent_id'); This module provides a few extra methods beyond what L and L already provide. my $parent = $item->parent(); $item->parent( $parent_obj ); $item->parent( $parent_id ); my $children_rs = $item->children(); my @children = $item->children(); $parent->append_child( $child ); $parent->prepend_child( $child ); $this->attach_before( $that ); $this->attach_after( $that ); =head1 DESCRIPTION This module provides methods for working with adjacency lists and ordered rows. All of the methods that L and L provide are available with this module. =head1 METHODS =head2 parent_column __PACKAGE__->parent_column('parent_id'); Works the same as AdjacencyList's parent_column() method, but it declares the children() has many relationship to be ordered by the position column. =cut sub parent_column { my $class = shift; my $position_col = $class->position_column() || croak('You must call position_column() before calling parent_column()'); if (@_) { $class->grouping_column( @_ ); $class->next::method( @_ ); $class->relationship_info('children')->{attrs}->{order_by} = $position_col; return 1; } return $class->grouping_column; } =head2 parent my $parent = $item->parent(); $item->parent( $parent_obj ); $item->parent( $parent_id ); This method overrides AdjacencyList's parent() method but modifies it so that the object is moved to the last position, then the parent is changed, and then it is moved to the last position of the new list, thus maintaining the intergrity of the ordered lists. =cut sub parent { my $self = shift; if (@_) { my $new_parent = shift; my $parent_col = $self->_parent_column(); if (ref($new_parent)) { $new_parent = $new_parent->id() || croak('Parent object does not have an ID');; } return 0 if ($new_parent == ($self->get_column($parent_col)||0)); $self->move_last; $self->set_column( $parent_col => $new_parent ); $self->set_column( $self->position_column() => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count() + 1 ); $self->update(); return 1; } return $self->_parent(); } =head2 children my $children_rs = $item->children(); my @children = $item->children(); This method works just like it does in the DBIx::Class::Tree::AdjacencyList module except it orders the children by there position. =head2 append_child $parent->append_child( $child ); Sets the child to have the specified parent and moves the child to the last position. =cut sub append_child { my( $self, $child ) = @_; $child->parent( $self ); } =head2 prepend_child $parent->prepend_child( $child ); Sets the child to have the specified parent and moves the child to the first position. =cut sub prepend_child { my( $self, $child ) = @_; $child->parent( $self ); $child->move_first(); } =head2 attach_before $this->attach_before( $that ); Attaches the object at the position just before the calling object's position. =cut sub attach_before { my( $self, $sibling ) = @_; $sibling->parent( $self->parent() ); $sibling->move_to( $self->get_column($self->position_column()) ); } =head2 attach_after $this->attach_after( $that ); Attaches the object at the position just after the calling object's position. =cut sub attach_after { my( $self, $sibling ) = @_; $sibling->parent( $self->parent() ); $sibling->move_to( $self->get_column($self->position_column()) + 1 ); } 1; __END__ =head1 INHERITED METHODS =head2 DBIx::Class::Ordered =over 4 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back =head2 DBIx::Class::Tree::AdjacencyList =over 4 =item * L =item * L =item * L =item * L =item * L =back =head2 DBIx::Class =over 4 =item * L =item * L =back =head2 DBIx::Class::Componentised =over 4 =item * L =item * L =item * L =back =head2 Class::Data::Accessor =over 4 =item * L =back =head1 AUTHOR Aran Clary Deltac =head1 LICENSE You may distribute this code under the same terms as Perl itself. DBIx-Class-Tree-0.03003/lib/DBIx/Class/Tree/AdjacencyList.pm0000644000175000017500000002246111516027140023120 0ustar ahartmaiahartmaipackage DBIx::Class::Tree::AdjacencyList; # vim: ts=8:sw=4:sts=4:et use strict; use warnings; use base qw( DBIx::Class ); use Carp qw( croak ); =head1 NAME DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. =head1 SYNOPSIS Create a table for your tree data. CREATE TABLE employees ( employee_id INTEGER PRIMARY KEY AUTOINCREMENT, parent_id INTEGER NOT NULL DEFAULT 0, name TEXT NOT NULL ); In your Schema or DB class add Tree::AdjacencyList to the top of the component list. __PACKAGE__->load_components(qw( Tree::AdjacencyList ... )); Specify the column that contains the parent ID of each row. package My::Employee; __PACKAGE__->parent_column('parent_id'); Optionally, automatically maintane a consistent tree structure. __PACKAGE__->repair_tree( 1 ); Thats it, now you can modify and analyze the tree. #!/usr/bin/perl use My::Employee; my $employee = My::Employee->create({ name=>'Matt S. Trout' }); my $rs = $employee->children(); my @siblings = $employee->children(); my $parent = $employee->parent(); $employee->parent( 7 ); =head1 DESCRIPTION This module provides methods for working with adjacency lists. The adjacency list model is a very common way of representing a tree structure. In this model each row in a table has a prent ID column that references the primary key of another row in the same table. Because of this the primary key must only be one column and is usually some sort of integer. The row with a parent ID of 0 is the root node and is usually the parent of all other rows. Although, there is no limitation in this module that would stop you from having multiple root nodes. =head1 METHODS =head2 parent_column __PACKAGE__->parent_column('parent_id'); Declares the name of the column that contains the self-referential ID which defines the parent row. This will create a has_many (children) and belongs_to (parent) relationship. This method also sets up an additional has_many relationship called parents which is useful when you want to treat an adjacency list as a DAG. =cut __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' ); sub parent_column { my $class = shift; if (@_) { my $parent_col = shift; my $primary_col = ($class->primary_columns())[0]; $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } ); $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } ); $class->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, { cascade_delete => 0, cascade_copy => 0 } ); $class->_parent_column( $parent_col ); return 1; } return $class->_parent_column(); } =head2 repair_tree __PACKAGE__->repair_tree( 1 ); When set a true value this flag causes all changes to a node's parent to trigger an integrity check on the tree. If, when changing a node's parent to one of it's descendents then all its children will first be moved to have the same current parent, and then the node's parent is changed. So, for example, if the tree is like this: A B C D E F And you execute: $b->parent( $d ); Since D is a descendant of B then all of D's siblings get their parent changed to A. Then B's parent is set to D. A C D B E F =cut __PACKAGE__->mk_classdata( 'repair_tree' => 0 ); =head2 parent my $parent = $employee->parent(); $employee->parent( $parent_obj ); $employee->parent( $parent_id ); Retrieves the object's parent object, or changes the object's parent to the specified parent or parent ID. If you would like to make the object the root node, just set the parent to 0. If you are setting the parent then 0 will be returned if the specified parent is already the object's parent and 1 on success. =cut sub parent { my $self = shift; if (@_) { my $new_parent = shift; my $parent_col = $self->_parent_column(); if (ref($new_parent)) { $new_parent = $new_parent->id() || croak('Parent object does not have an ID');; } return 0 if ($new_parent == ($self->get_column($parent_col)||0)); if ($self->repair_tree()) { my $found = $self->has_descendant( $new_parent ); if ($found) { my $children = $self->children(); while (my $child = $children->next()) { $child->parent( $self->$parent_col() ); } } } $self->set_column( $parent_col => $new_parent ); $self->update(); return 1; } return $self->_parent(); } =head2 ancestors @list = $employee->ancestors(); Returns a list of ancestors starting with a record's parent and moving toward the tree root. =cut sub ancestors { my $self = shift; my @ancestors = (); my $rec = $self; while ($rec = $rec->parent) { push(@ancestors, $rec); } return @ancestors; } =head2 has_descendant if ($employee->has_descendant( $id )) { ... } Returns true if the object has a descendant with the specified ID. =cut sub has_descendant { my ($self, $find_id) = @_; my $children = $self->children(); while (my $child = $children->next()) { if ($child->id() eq $find_id) { return 1; } return 1 if ($child->has_descendant( $find_id )); } return 0; } =head2 parents my $parents = $node->parents(); my @parents = $node->parents(); This has_many relationship is not that useful as it will never return more than one parent due to the one-to-many structure of adjacency lists. The reason this relationship is defined is so that this tree type may be treated as if it was a DAG. =head2 children my $children_rs = $employee->children(); my @children = $employee->children(); Returns a list or record set, depending on context, of all the objects one level below the current one. This method is created when parent_column() is called, which sets up a has_many relationship called children. =head2 attach_child $parent->attach_child( $child ); $parent->attach_child( $child, $child, ... ); Sets the child, or children, to the new parent. Returns 1 on success and returns 0 if the parent object already has the child. =cut sub attach_child { my $self = shift; my $return = 1; foreach my $child (@_) { $child->parent( $self ); } return $return; } =head2 siblings my $rs = $node->siblings(); my @siblings = $node->siblings(); Returns either a result set or an array of all other objects with the same parent as the calling object. =cut sub siblings { my( $self ) = @_; my $parent_col = $self->_parent_column; my $primary_col = ($self->primary_columns())[0]; my $rs = $self->result_source->resultset->search( { $parent_col => $self->get_column($parent_col), $primary_col => { '!=' => $self->get_column($primary_col) }, }, ); return $rs->all() if (wantarray()); return $rs; } =head2 attach_sibling $obj->attach_sibling( $sibling ); $obj->attach_sibling( $sibling, $sibling, ... ); Sets the passed in object(s) to have the same parent as the calling object. Returns 1 on success and 0 if the sibling already has the same parent. =cut sub attach_sibling { my $self = shift; my $return = 1; foreach my $node (@_) { $return = 0 if (!$node->parent( $self->parent() )); } return $return; } =head2 is_leaf if ($obj->is_leaf()) { ... } Returns 1 if the object has no children, and 0 otherwise. =cut sub is_leaf { my( $self ) = @_; my $has_child = $self->children_rs->count(); return $has_child ? 0 : 1; } =head2 is_root if ($obj->is_root()) { ... } Returns 1 if the object has no parent, and 0 otherwise. =cut sub is_root { my( $self ) = @_; return ( $self->get_column( $self->_parent_column ) ? 0 : 1 ); } =head2 is_branch if ($obj->is_branch()) { ... } Returns 1 if the object has a parent and has children. Returns 0 otherwise. =cut sub is_branch { my( $self ) = @_; return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 ); } =head2 set_primary_key This method is an override of DBIx::Class' method for setting the class' primary key column(s). This method passes control right on to the normal method after first validating that only one column is being selected as a primary key. If more than one column is then an error will be thrown. =cut sub set_primary_key { my $self = shift; if (@_>1) { croak('You may only specify a single column as the primary key for adjacency tree classes'); } return $self->next::method( @_ ); } 1; __END__ =head1 INHERITED METHODS =head2 DBIx::Class =over 4 =item * L =item * L =back =head2 DBIx::Class::Componentised =over 4 =item * L =item * L =item * L =back =head2 Class::Data::Accessor =over 4 =item * L =back =head1 AUTHOR Aran Clary Deltac =head1 LICENSE You may distribute this code under the same terms as Perl itself. DBIx-Class-Tree-0.03003/MANIFEST0000644000175000017500000000113111516075255015677 0ustar ahartmaiahartmaiChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/Class/Tree.pm lib/DBIx/Class/Tree/AdjacencyList.pm lib/DBIx/Class/Tree/AdjacencyList/Ordered.pm Makefile.PL MANIFEST This list of files META.yml README t/01_pod.t t/10_adjacencylist.t t/11_adjacencylist_ordered.t t/lib/sqlite.sql t/lib/TreeTest.pm t/lib/TreeTest/Schema.pm t/lib/TreeTest/Schema/Node.pm t/var/test.db TODO DBIx-Class-Tree-0.03003/Makefile.PL0000644000175000017500000000072211510372152016513 0ustar ahartmaiahartmaiuse inc::Module::Install; BEGIN { if ($Module::Install::AUTHOR) { require Module::Install::ReadmeFromPod; } } name 'DBIx-Class-Tree'; perl_version '5.008001'; all_from 'lib/DBIx/Class/Tree.pm'; readme_from 'lib/DBIx/Class/Tree.pm'; resources 'repository' => 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class-Tree.git'; requires 'DBIx::Class' => '0.08100'; test_requires 'Test::Exception'; WriteAll; DBIx-Class-Tree-0.03003/META.yml0000644000175000017500000000123511516075253016022 0ustar ahartmaiahartmai--- abstract: 'Manipulate and anaylze tree structured data.' author: - 'Aran Clary Deltac ' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0 configure_requires: 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 name: DBIx-Class-Tree no_index: directory: - inc - t requires: DBIx::Class: 0.08100 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class-Tree.git version: 0.03003 DBIx-Class-Tree-0.03003/t/0000755000175000017500000000000011516075343015013 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/t/11_adjacencylist_ordered.t0000644000175000017500000000076111510371717022024 0ustar ahartmaiahartmai# vim: filetype=perl:ts=8:sw=4:sts=4:et use strict; use warnings; use lib 't/lib'; use Test::More; BEGIN { # This must happen before the schema is loaded require TreeTest::Schema::Node; TreeTest::Schema::Node->load_components(qw( Tree::AdjacencyList::Ordered )); TreeTest::Schema::Node->position_column( 'position' ); TreeTest::Schema::Node->parent_column( 'parent_id' ); } use TreeTest; my $tests = TreeTest::count_tests(); plan tests => $tests; TreeTest::run_tests(); 1; DBIx-Class-Tree-0.03003/t/lib/0000755000175000017500000000000011516075343015561 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/t/lib/sqlite.sql0000644000175000017500000000025011510371717017576 0ustar ahartmaiahartmai CREATE TABLE nodes ( node_id INTEGER PRIMARY KEY AUTOINCREMENT, name STRING, parent_id INTEGER, position INTEGER, lft INTEGER, rgt INTEGER ); DBIx-Class-Tree-0.03003/t/lib/TreeTest.pm0000644000175000017500000000607211510371717017661 0ustar ahartmaiahartmaipackage TreeTest; use strict; use warnings; use Test::More; use Test::Exception; use TreeTest::Schema; our $NODE_COUNT = 80; sub count_tests { my $count = 17; if( TreeTest::Schema::Node->can('position_column') ){ $count ++; } return $count; } sub run_tests { my $schema = TreeTest::Schema->connect(); my $nodes = $schema->resultset('Node'); my $root = $nodes->create({ name=>'root' }); my @parents = ( 1,1,3,4,4,3,3,8,8,10,10,8,8,3,3,16,3,3,1,20,1,22,22,24,24,22,27,27,29,29,27,32,32,34,34,36,34,38,38,40,40,42,42,44,44,46,44,44,49,44,51,51,53,51,55,55,57,57,55,60,55,62,55,64,64,55,67,67,55,70,70,55,55,51,51,76,76,78,78,76 ); foreach my $parent_id (@parents) { my $node = $nodes->create({ name=>'child' }); $node->parent( $parent_id ); } ok( ($nodes->count()==81), 'correct number of nodes in random tree' ); ok( ($nodes->find(3)->children->count()==7), 'node 3 has correct number of children' ); ok( ($nodes->find(22)->children->count()==3), 'node 22 has correct number of children' ); my $child = ($nodes->find(22)->children->all())[0]; $child->parent( $nodes->find(3) ); ok( ($nodes->find(3)->children->count()==8), 'node 3 has correct number of children' ); ok( ($nodes->find(3)->siblings->count()==3), 'node 3 has correct number of siblings' ); ok( ($nodes->find(22)->children->count()==2), 'node 22 has correct number of children' ); ok( ($nodes->find(22)->siblings->count()==3), 'node 22 has correct number of siblings' ); $nodes->find(22)->attach_child( $nodes->find(3) ); ok( ($nodes->find(22)->children->count()==3), 'node 22 has correct number of children' ); ok( ($nodes->find(22)->siblings->count()==2), 'node 22 has correct number of siblings' ); $nodes->find(22)->attach_sibling( $nodes->find(3) ); ok( ($nodes->find(22)->children->count()==2), 'node 22 has correct number of children' ); ok( ($nodes->find(22)->siblings->count()==3), 'node 22 has correct number of siblings' ); ok( ($nodes->find(22)->parents->count()==1), 'node 22 has correct number of parents' ); ok( (($nodes->find(22)->parents->all())[0]->id()==$nodes->find(22)->parent->id()), 'node 22 parent matches parents' ); my @ancestors = $nodes->find(44)->ancestors(); ok( scalar(@ancestors)==8, 'node 44 has correct number of ancestors' ); ok( $ancestors[0]->id == $nodes->find(44)->parent_id, 'node 44\'s first ancestor is its parent' ); ok( $ancestors[-1]->name eq 'root', 'node 44\'s last ancestor is root' ); if( TreeTest::Schema::Node->can('position_column') ){ ok( check_positions(scalar $root->children()), 'positions are correct' ); } lives_and ( sub { is( $nodes->find(3)->copy({name => 'special'})->name,'special','copy test'); }, 'copy does not throw'); } sub check_positions { my $nodes = shift; my $position = 0; while (my $node = $nodes->next()) { $position ++; return 0 if ($node->position() != $position); return 0 if ( !check_positions(scalar $node->children()) ); } return 1; } 1; DBIx-Class-Tree-0.03003/t/lib/TreeTest/0000755000175000017500000000000011516075343017320 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/t/lib/TreeTest/Schema.pm0000644000175000017500000000142211510371717021053 0ustar ahartmaiahartmaipackage TreeTest::Schema; use strict; use warnings; use base qw( DBIx::Class::Schema ); __PACKAGE__->load_classes(); sub connect { my $self = shift; my $db_file = 't/var/test.db'; unlink($db_file) if -e $db_file; unlink($db_file . '-journal') if -e $db_file . '-journal'; mkdir("t/var") unless -d "t/var"; my $dsn = "dbi:SQLite:$db_file"; my $schema = $self->next::method( $dsn ); $schema->storage->on_connect_do([ "PRAGMA synchronous = OFF" ]); my $dbh = $schema->storage->dbh; open SQL, "t/lib/sqlite.sql"; my $sql; { local $/ = undef; $sql = ; } close SQL; $dbh->do($_) for split(/\n\n/, $sql); $schema->storage->dbh->do("PRAGMA synchronous = OFF"); return $schema; } 1; DBIx-Class-Tree-0.03003/t/lib/TreeTest/Schema/0000755000175000017500000000000011516075343020520 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/t/lib/TreeTest/Schema/Node.pm0000644000175000017500000000055011510371717021741 0ustar ahartmaiahartmaipackage TreeTest::Schema::Node; use strict; use warnings; use base qw( DBIx::Class ); __PACKAGE__->load_components(qw( PK::Auto Core )); __PACKAGE__->table('nodes'); __PACKAGE__->add_columns( node_id => { is_auto_increment => 1 }, qw/ name parent_id position lft rgt / ); __PACKAGE__->set_primary_key( 'node_id' ); 1; DBIx-Class-Tree-0.03003/t/01_pod.t0000644000175000017500000000027611510371717016265 0ustar ahartmaiahartmaiuse Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_files_ok(); DBIx-Class-Tree-0.03003/t/10_adjacencylist.t0000644000175000017500000000065711510371717020323 0ustar ahartmaiahartmai# vim: filetype=perl:ts=8:sw=4:sts=4:et use strict; use warnings; use lib 't/lib'; use Test::More; BEGIN { # This must happen before the schema is loaded require TreeTest::Schema::Node; TreeTest::Schema::Node->load_components(qw( Tree::AdjacencyList )); TreeTest::Schema::Node->parent_column( 'parent_id' ); } use TreeTest; my $tests = TreeTest::count_tests(); plan tests => $tests; TreeTest::run_tests(); 1; DBIx-Class-Tree-0.03003/t/var/0000755000175000017500000000000011516075343015603 5ustar ahartmaiahartmaiDBIx-Class-Tree-0.03003/t/var/test.db0000644000175000017500000001200011516027143017055 0ustar ahartmaiahartmaiSQLite format 3@ - BP++Ytablesqlite_sequencesqlite_sequenceCREATE TABLE sqlite_sequence(name,seq);UtablenodesnodesCREATE TABLE nodes ( node_id INTEGER PRIMARY KEY AUTOINCREMENT, name STRING, parent_id INTEGER, position INTEGER, lft INTEGER, rgt INTEGER )rbRB2"rbRB2"rbRB2"8child77child36child55child34child33child,2child11child,0child,/child..child,-child,,child*+child**child()child((child&'child&&child"%child$$child"#child""child !child  childchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchild child child  child  child childchildchildchildchildchildchildchild 8  nodesc 8rbRB2"rbRB2"rbRB2"8child77child36child55child34child33child,2child11child,0child,/child..child,-child,,child*+child**child()child((child&'child&&child"%child$$child"#child""child !child  childchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchildchild child child  child  child childchildchildchildchildchildchildchild root +Np`P@0 p^N>.~n^NcchildRbchildRachildR`child__childR^childR]childW\childW[childYZchildYYchildWXchildWWchildRVchildRUchildSTchildSSchildRRspecialQchildLPchildNOchildNNchildLMchildLLchild3Kchild3Jchild7 Ichild7HchildFGchildFFchild7EchildCDchildCCchild7Bchild@Achild@@child7?child>>child7=child<<child7;child9:child99child7