r604 - in packages/libclass-default-perl/branches/upstream/current:
. inc inc/Module inc/Module/Install lib/Class t
Allard Hoeve
hoeve-guest at costa.debian.org
Sun Jul 17 08:08:47 UTC 2005
Author: hoeve-guest
Date: 2005-01-10 15:09:42 +0100 (Mon, 10 Jan 2005)
New Revision: 604
Added:
packages/libclass-default-perl/branches/upstream/current/Build.PL
packages/libclass-default-perl/branches/upstream/current/inc/
packages/libclass-default-perl/branches/upstream/current/inc/Module/
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/AutoInstall.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Base.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Build.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Can.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Fetch.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Makefile.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Metadata.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Win32.pm
packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm
packages/libclass-default-perl/branches/upstream/current/t/00_compile.t
Modified:
packages/libclass-default-perl/branches/upstream/current/MANIFEST
packages/libclass-default-perl/branches/upstream/current/META.yml
packages/libclass-default-perl/branches/upstream/current/Makefile.PL
packages/libclass-default-perl/branches/upstream/current/README
packages/libclass-default-perl/branches/upstream/current/lib/Class/Default.pm
packages/libclass-default-perl/branches/upstream/current/t/01_main.t
Log:
Load /tmp/tmp.dbnEca/libclass-default-perl-1.1 into
packages/libclass-default-perl/branches/upstream/current.
Added: packages/libclass-default-perl/branches/upstream/current/Build.PL
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/Build.PL 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/Build.PL 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,2 @@
+#!/usr/bin/perl
+require "Makefile.PL";
Modified: packages/libclass-default-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/MANIFEST 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/MANIFEST 2005-01-10 14:09:42 UTC (rev 604)
@@ -1,8 +1,20 @@
+Build.PL
Changes
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Build.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
lib/Class/Default.pm
LICENSE
Makefile.PL
MANIFEST This list of files
+META.yml
README
+t/00_compile.t
t/01_main.t
-META.yml Module meta-data (added by MakeMaker)
Modified: packages/libclass-default-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/META.yml 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/META.yml 2005-01-10 14:09:42 UTC (rev 604)
@@ -1,13 +1,15 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
-name: Class-Default
-version: 1.0
-version_from: lib/Class/Default.pm
-installdirs: site
+name: Class-Default
+version: 1.1
+abstract: Static methods apply to a default instantiation
+author: Adam Kennedy<cpan at ali.as>
+license: perl
+distribution_type: module
+build_requires:
+ Test::More: 0.47
+ File::Spec: 0.82
requires:
- Class::Inspector: 1
- File::Spec: 0.83
- Test::More: 0
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.16
+ perl: 5.005
+no_index:
+ directory:
+ - inc
+generated_by: Module::Install version 0.35
Modified: packages/libclass-default-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/Makefile.PL 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/Makefile.PL 2005-01-10 14:09:42 UTC (rev 604)
@@ -1,15 +1,16 @@
-require 5.000;
-use ExtUtils::MakeMaker;
-WriteMakefile(
- 'NAME' => 'Class::Default',
- 'VERSION_FROM' => 'lib/Class/Default.pm',
- 'PREREQ_PM' => {
- 'File::Spec' => 0.83,
- 'Test::More' => 0,
- 'Class::Inspector' => 1,
- },
- ($] >= 5.005) ? (
- 'AUTHOR' => 'Adam Kennedy (cpan at ali.as)',
- 'ABSTRACT' => "Static methods apply to a default instantiation",
- ) : (),
-);
+use inc::Module::Install;
+
+name ( 'Class-Default');
+abstract ( 'Static methods apply to a default instantiation');
+author ( 'Adam Kennedy<cpan at ali.as>');
+version_from ( 'lib/Class/Default.pm');
+license ( 'perl');
+
+requires ( 'perl' => '5.005' );
+
+build_requires( 'Test::More' => '0.47' );
+build_requires( 'File::Spec' => '0.82' );
+
+auto_install();
+
+&WriteAll;
Modified: packages/libclass-default-perl/branches/upstream/current/README
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/README 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/README 2005-01-10 14:09:42 UTC (rev 604)
@@ -2,26 +2,26 @@
Class::Default - Static calls apply to a default instantiation
SYNOPSIS
- # Create the defaulted class
- package Foo::Base;
-
- use base 'Class::Default';
-
- sub new { bless {}, $_[0] }
-
- sub show {
- my $self = shift->_self;
- "$self";
- }
-
- # Do something to the default object
-
- package main;
-
- print Foo::Bar->show;
-
- # Prints 'Foo::Bar=HASH(0x80d22f8)'
-
+ # Create the defaulted class
+ package Foo::Base;
+
+ use base 'Class::Default';
+
+ sub new { bless {}, $_[0] }
+
+ sub show {
+ my $self = shift->_self;
+ "$self";
+ }
+
+ # Do something to the default object
+
+ package main;
+
+ print Foo::Bar->show;
+
+ # Prints 'Foo::Bar=HASH(0x80d22f8)'
+
DESCRIPTION
Class::Default provides a mechanism to allow your class to take static
method calls and apply it to a default instantiation of an object. It
@@ -58,21 +58,21 @@
A typical method will look something like the following
- sub foobar {
- my $self = shift;
-
- # Do whatever the method does
- }
-
+ sub foobar {
+ my $self = shift;
+
+ # Do whatever the method does
+ }
+
To make the method work with Class::Default, you should change it to the
following
- sub foobar {
- my $self = shift->_self;
-
- # Do whatever the method does
- }
-
+ sub foobar {
+ my $self = shift->_self;
+
+ # Do whatever the method does
+ }
+
This change is very low impact, easy to use, and will not make any other
differences to the way your code works.
@@ -93,42 +93,42 @@
demonstrate the use of "_create_default_object" to set some values in
the default object.
- package Slashdot::User;
-
- use base 'Class::Default';
-
- # Constructor
- sub new {
- my $class = shift;
- my $name = shift;
-
- my $self = {
- name => $name,
- favourite_color => '',
- };
-
- return bless $self, $class;
- }
-
- # Default constructor
- sub _create_default_object {
- my $class = shift;
-
- my $self = $class->new( 'Anonymous Coward' );
- $self->{favourite_color} = 'Orange';
-
- return $self;
- }
-
- sub name { $_[0]->{name} }
- sub favourite_color { $_[0]->{favourite_color} }
-
+ package Slashdot::User;
+
+ use base 'Class::Default';
+
+ # Constructor
+ sub new {
+ my $class = shift;
+ my $name = shift;
+
+ my $self = {
+ name => $name,
+ favourite_color => '',
+ };
+
+ return bless $self, $class;
+ }
+
+ # Default constructor
+ sub _create_default_object {
+ my $class = shift;
+
+ my $self = $class->new( 'Anonymous Coward' );
+ $self->{favourite_color} = 'Orange';
+
+ return $self;
+ }
+
+ sub name { $_[0]->{name} }
+ sub favourite_color { $_[0]->{favourite_color} }
+
That provides a statically accessible default object that could be used
as in the following manner.
- print "The default slashdot user is " . Slashdot::User->name
- . " and they like the colour " . Slashdot::User->favourite_color;
-
+ print "The default slashdot user is " . Slashdot::User->name
+ . " and they like the colour " . Slashdot::User->favourite_color;
+
Remember that the default object is persistant, so changes made to the
statically accessible object can be recovered later.
@@ -136,8 +136,8 @@
There are a few ways to do this, but the easiest way is to simple do the
following
- my $default = Slashdot::User->_get_default;
-
+ my $default = Slashdot::User->_get_default;
+
METHODS
_self
Used by methods to make the method apply to the default object if called
@@ -161,16 +161,15 @@
No known bugs, but suggestions are welcome
SUPPORT
+ Bugs should be reported via the CPAN bug tracker at
+
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class%3ADefault>
+
Contact the author
AUTHOR
- Adam Kennedy
- cpan at ali.as
- http://ali.as/
+ Adam Kennedy (Maintainer), <http://ali.as/>, cpan at ali.as
-SEE ALSO
- Class::*
-
COPYRIGHT
Copyright (c) 2002 Adam Kennedy. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/AutoInstall.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/AutoInstall.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/AutoInstall.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,65 @@
+#line 1 "inc/Module/Install/AutoInstall.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/AutoInstall.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/AutoInstall.pm $ $Author: autrijus $
+# $Revision: #13 $ $Change: 1846 $ $DateTime: 2003/12/31 22:57:12 $ vim: expandtab shiftwidth=4
+
+package Module::Install::AutoInstall;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub AutoInstall { $_[0] }
+
+sub run {
+ my $self = shift;
+ $self->auto_install_now(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->auto_install(@_);
+}
+
+sub auto_install {
+ my $self = shift;
+ return if $self->{done}++;
+
+# ExtUtils::AutoInstall Bootstrap Code, version 7.
+AUTO:{my$p='ExtUtils::AutoInstall';my$v=0.49;$p->VERSION||0>=$v
+or+eval"use $p $v;1"or+do{my$e=$ENV{PERL_EXTUTILS_AUTOINSTALL};
+(!defined($e)||$e!~m/--(?:default|skip|testonly)/and-t STDIN or
+eval"use ExtUtils::MakeMaker;WriteMakefile(PREREQ_PM=>{'$p',$v}
+);1"and exit)and print"==> $p $v required. Install it from CP".
+"AN? [Y/n] "and<STDIN>!~/^n/i and print"*** Installing $p\n"and
+do{if (eval '$>' and lc(`sudo -V`) =~ /version/){system('sudo',
+$^X,"-MCPANPLUS","-e","CPANPLUS::install $p");eval"use $p $v;1"
+||system('sudo', $^X, "-MCPAN", "-e", "CPAN::install $p")}eval{
+require CPANPLUS;CPANPLUS::install$p};eval"use $p $v;1"or eval{
+require CPAN;CPAN::install$p};eval"use $p $v;1"||die"*** Please
+manually install $p $v from cpan.org first...\n"}}}
+
+ # Flatten array of arrays into a single array
+ my @core = map @$_, map @$_, grep ref,
+ $self->build_requires, $self->requires;
+
+ while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
+ push @core, splice(@_, 0, 2);
+ }
+
+ ExtUtils::AutoInstall->import(
+ (@core ? (-core => \@core) : ()), @_, $self->features
+ );
+
+ $self->makemaker_args( ExtUtils::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ ExtUtils::AutoInstall::postamble()
+ );
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install;
+ ExtUtils::AutoInstall::do_install();
+}
+
+1;
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Base.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Base.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Base.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,57 @@
+#line 1 "inc/Module/Install/Base.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Base.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Base.pm $ $Author: autrijus $
+# $Revision: #10 $ $Change: 1847 $ $DateTime: 2003/12/31 23:14:54 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Base;
+
+#line 31
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method (qw(call load)) {
+ *{"$class\::$method"} = sub {
+ +shift->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless(\%args, $class);
+}
+
+#line 49
+
+sub AUTOLOAD {
+ my $self = shift;
+ goto &{$self->_top->autoload};
+}
+
+#line 60
+
+sub _top { $_[0]->{_top} }
+
+#line 71
+
+sub admin {
+ my $self = shift;
+ $self->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+sub is_admin {
+ my $self = shift;
+ $self->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+sub AUTOLOAD {}
+sub DESTROY {}
+
+1;
+
+__END__
+
+#line 115
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Build.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Build.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Build.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,66 @@
+#line 1 "inc/Module/Install/Build.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Build.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Build.pm $ $Author: ingy $
+# $Revision: #23 $ $Change: 1255 $ $DateTime: 2003/03/05 13:23:32 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Build;
+$VERSION = '0.01';
+use strict;
+use vars qw(@ISA);
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub Build { $_[0] }
+
+sub write {
+ my $self = shift;
+ die "Build->write() takes no arguments\n" if @_;
+
+ my %args;
+ my $build;
+
+ $args{dist_name} = $self->name || $self->determine_NAME($self->{args});
+ $args{license} = $self->license;
+ $args{dist_version} = $self->version || $self->determine_VERSION($self->{args});
+ $args{dist_abstract} = $self->abstract;
+ $args{dist_author} = $self->author;
+ $args{sign} = $self->sign;
+ $args{no_index} = $self->no_index;
+
+ foreach my $key (qw(build_requires requires recommends conflicts)) {
+ my $val = eval "\$self->$key" or next;
+ $args{$key} = { map @$_, @$val };
+ }
+
+ %args = map {($_, $args{$_})} grep {defined($args{$_})} keys %args;
+
+ require Module::Build;
+ $build = Module::Build->new(%args);
+ $build->add_to_cleanup(split /\s+/, $self->clean_files);
+ $build->create_build_script;
+}
+
+sub ACTION_reset {
+ my ($self) = @_;
+ die "XXX - Can't get this working yet";
+ require File::Path;
+ warn "Removing inc\n";
+ rmpath('inc');
+}
+
+sub ACTION_dist {
+ my ($self) = @_;
+ die "XXX - Can't get this working yet";
+}
+
+# <ingy> DrMath: is there an OO way to add actions to Module::Build??
+# <DrMath> ingy: yeah
+# <DrMath> ingy: package MyBuilder; use w(Module::Build; @ISA = qw(w(Module::Build); sub ACTION_ingy
+# {...}
+# <DrMath> ingy: then my $build = new MyBuilder( ...parameters... );
+# $build->write_build_script;
+
+
+1;
+
+__END__
+
+#line 178
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Can.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Can.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Can.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,41 @@
+#line 1 "inc/Module/Install/Can.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Can.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Can.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1840 $ $DateTime: 2003/12/28 19:42:02 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Can;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+$VERSION = '0.01';
+
+use strict;
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+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;
+}
+
+1;
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Fetch.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Fetch.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Fetch.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,89 @@
+#line 1 "inc/Module/Install/Fetch.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Fetch.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Fetch.pm $ $Author: autrijus $
+# $Revision: #8 $ $Change: 1374 $ $DateTime: 2003/03/18 11:50:15 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Fetch;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.01';
+
+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 at 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/, << ".");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+.
+ 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;
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Makefile.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Makefile.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Makefile.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,146 @@
+#line 1 "inc/Module/Install/Makefile.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Makefile.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Makefile.pm $ $Author: autrijus $
+# $Revision: #53 $ $Change: 1847 $ $DateTime: 2003/12/31 23:14:54 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Makefile;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.01';
+
+use strict 'vars';
+use vars '$VERSION';
+
+use ExtUtils::MakeMaker ();
+
+sub Makefile { $_[0] }
+
+sub prompt {
+ shift;
+ goto &ExtUtils::MakeMaker::prompt;
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join(" ", grep length, $clean->{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 write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 ) {
+ $args->{SIGN} = 1 if $self->sign;
+ }
+ delete $args->{SIGN} unless $self->is_admin;
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
+ ($self->build_requires, $self->requires) );
+
+ # merge both kinds of requires into prereq_pm
+ my $dir = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ push @$dir, map "$_->[1]", @{$self->bundles};
+ delete $prereq->{$_->[0]} for @{$self->bundles};
+ }
+
+ 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";
+ }
+
+ my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args;
+
+ if ($self->admin->preop) {
+ $args{dist} = $self->admin->preop;
+ }
+
+ ExtUtils::MakeMaker::WriteMakefile(%args);
+
+ $self->fix_up_makefile();
+}
+
+sub fix_up_makefile {
+ my $self = 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 || '');
+
+ open MAKEFILE, '< Makefile' or die $!;
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE;
+
+ $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;
+
+ open MAKEFILE, '> Makefile' or die $!;
+ print MAKEFILE "$preamble$makefile$postamble";
+ close MAKEFILE;
+}
+
+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 276
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Metadata.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Metadata.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Metadata.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,190 @@
+#line 1 "inc/Module/Install/Metadata.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Metadata.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Metadata.pm $ $Author: autrijus $
+# $Revision: #32 $ $Change: 1885 $ $DateTime: 2004/03/11 05:55:27 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Metadata;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.04';
+
+use strict 'vars';
+use vars qw($VERSION);
+
+sub Meta { shift }
+
+my @scalar_keys = qw(
+ name module_name version abstract author license
+ distribution_type sign perl_version
+);
+my @tuple_keys = qw(build_requires requires recommends bundles);
+
+foreach my $key (@scalar_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{'values'}{$key} unless @_;
+ $self->{'values'}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{'values'}{$key} unless @_;
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ($module eq 'perl') {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [$module, $version];
+ push @{$self->{'values'}{$key}}, $rv;
+ push @rv, $rv;
+ }
+ return @rv;
+ };
+}
+
+sub features {
+ my $self = shift;
+ while (my ($name, $mods) = splice(@_, 0, 2)) {
+ my $count = 0;
+ push @{$self->{'values'}{'features'}}, ($name => [
+ map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods
+ ] );
+ }
+ return @{$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 _dump {
+ my $self = shift;
+ my $package = ref($self->_top);
+ my $version = $self->_top->VERSION;
+ my %values = %{$self->{'values'}};
+
+ delete $values{sign};
+ if (my $perl_version = delete $values{perl_version}) {
+ # Always canonical to three-dot version
+ $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
+ if $perl_version >= 5.006;
+ $values{requires} = [
+ [perl => $perl_version],
+ @{$values{requires}||[]},
+ ];
+ }
+
+ warn "No license specified, setting license = 'unknown'\n"
+ unless $values{license};
+
+ $values{license} ||= 'unknown';
+ $values{distribution_type} ||= 'module';
+ $values{name} ||= do {
+ my $name = $values{module_name};
+ $name =~ s/::/-/g;
+ $name;
+ } if $values{module_name};
+
+ if ($values{name} =~ /::/) {
+ my $name = $values{name};
+ $name =~ s/::/-/g;
+ die "Error in name(): '$values{name}' should be '$name'!\n";
+ }
+
+ my $dump = '';
+ foreach my $key (@scalar_keys) {
+ $dump .= "$key: $values{$key}\n" if exists $values{$key};
+ }
+ foreach my $key (@tuple_keys) {
+ next unless exists $values{$key};
+ $dump .= "$key:\n";
+ foreach (@{$values{$key}}) {
+ $dump .= " $_->[0]: $_->[1]\n";
+ }
+ }
+
+ if (my $no_index = $values{no_index}) {
+ push @{$no_index->{'directory'}}, 'inc';
+ require YAML;
+ local $YAML::UseHeader = 0;
+ $dump .= YAML::Dump({ no_index => $no_index});
+ }
+ else {
+ $dump .= << "META";
+no_index:
+ directory:
+ - inc
+META
+ }
+
+ $dump .= "generated_by: $package version $version\n";
+ return $dump;
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML', 0 );
+ require YAML;
+ my $data = YAML::LoadFile( 'META.yml' );
+ # Call methods explicitly in case user has already set some values.
+ while ( my ($key, $value) = each %$data ) {
+ next unless $self->can( $key );
+ if (ref $value eq 'HASH') {
+ while (my ($module, $version) = each %$value) {
+ $self->$key( $module => $version );
+ }
+ }
+ else {
+ $self->$key( $value );
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+
+ META_NOT_OURS: {
+ local *FH;
+ if (open FH, "META.yml") {
+ while (<FH>) {
+ last META_NOT_OURS if /^generated_by: Module::Install\b/;
+ }
+ return $self if -s FH;
+ }
+ }
+
+ warn "Writing META.yml\n";
+ open META, "> META.yml" or warn "Cannot write to META.yml: $!";
+ print META $self->_dump;
+ close META;
+ return $self;
+}
+
+sub version_from {
+ my ($self, $version_from) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version(ExtUtils::MM_Unix->parse_version($version_from));
+}
+
+sub abstract_from {
+ my ($self, $abstract_from) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix')
+ ->parse_abstract($abstract_from)
+ );
+}
+
+1;
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Win32.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Win32.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/Win32.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,66 @@
+#line 1 "inc/Module/Install/Win32.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/Win32.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/Win32.pm $ $Author: autrijus $
+# $Revision: #9 $ $Change: 1789 $ $DateTime: 2003/11/11 01:22:54 $ vim: expandtab shiftwidth=4
+
+package Module::Install::Win32;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.02';
+
+use strict;
+
+# 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 (
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ $^O eq 'MSWin32' and
+ !$self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ if (!$rv) {
+ die << '.';
+
+-------------------------------------------------------------------------------
+
+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.
+
+-------------------------------------------------------------------------------
+.
+ }
+}
+
+1;
+
+__END__
+
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,39 @@
+#line 1 "inc/Module/Install/WriteAll.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install/WriteAll.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install/WriteAll.pm $ $Author: autrijus $
+# $Revision: #3 $ $Change: 1885 $ $DateTime: 2004/03/11 05:55:27 $ vim: expandtab shiftwidth=4
+
+package Module::Install::WriteAll;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ($0 =~ /Build.PL$/i) {
+ $self->Build->write;
+ }
+ else {
+ $self->check_nmake if $args{check_nmake};
+ $self->makemaker_args( PL_FILES => {} )
+ unless $self->makemaker_args->{'PL_FILES'};
+
+ if ($args{inline}) {
+ $self->Inline->write;
+ }
+ else {
+ $self->Makefile->write;
+ }
+ }
+}
+
+1;
Added: packages/libclass-default-perl/branches/upstream/current/inc/Module/Install.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/inc/Module/Install.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/inc/Module/Install.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,172 @@
+#line 1 "inc/Module/Install.pm - /usr/lib/perl5/site_perl/5.8.0/Module/Install.pm"
+# $File: //depot/cpan/Module-Install/lib/Module/Install.pm $ $Author: autrijus $
+# $Revision: #69 $ $Change: 2301 $ $DateTime: 2004/07/13 07:16:40 $ vim: expandtab shiftwidth=4
+
+package Module::Install;
+$VERSION = '0.35';
+
+die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'};
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+.
+
+use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
+
+ at inc::Module::Install::ISA = 'Module::Install';
+*inc::Module::Install::VERSION = *VERSION;
+
+#line 132
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+
+ if (not -f $self->{file}) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} =
+ "$self->{name}::$self->{dispatch}"->new(_top => $self);
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{caller(0) . "::AUTOLOAD"} = $self->autoload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+}
+
+#line 159
+
+sub autoload {
+ my $self = shift;
+ my $caller = caller;
+
+ my $cwd = Cwd::cwd();
+ my $sym = "$caller\::AUTOLOAD";
+
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if (my $code = $sym->{$pwd}) {
+ goto &$code unless $cwd eq $pwd; # delegate back to parent dirs
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+#line 184
+
+sub new {
+ my ($class, %args) = @_;
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= '.author';
+ $args{bundle} ||= 'inc/BUNDLES';
+
+ $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{prefix}/$args{path}.pm";
+
+ bless(\%args, $class);
+}
+
+#line 213
+
+sub call {
+ my $self = shift;
+ my $method = shift;
+ my $obj = $self->load($method) or return;
+
+ unshift @_, $obj;
+ goto &{$obj->can($method)};
+}
+
+#line 228
+
+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";
+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
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+#line 258
+
+sub load_extensions {
+ my ($self, $path, $top_obj) = @_;
+
+ unshift @INC, $self->{prefix}
+ unless grep { $_ eq $self->{prefix} } @INC;
+
+ local @INC = ($path, @INC);
+ foreach my $rv ($self->find_extensions($path)) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ eval { require $file; 1 } or (warn($@), next);
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, $pkg->new( _top => $top_obj );
+ }
+}
+
+#line 282
+
+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;
+ return if $1 eq $self->{dispatch};
+
+ $file = "$self->{path}/$1.pm";
+ my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g;
+ push @found, [$file, $pkg];
+ }, $path) if -d $path;
+
+ @found;
+}
+
+1;
+
+__END__
+
+#line 620
Modified: packages/libclass-default-perl/branches/upstream/current/lib/Class/Default.pm
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/lib/Class/Default.pm 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/lib/Class/Default.pm 2005-01-10 14:09:42 UTC (rev 604)
@@ -1,262 +1,260 @@
-package Class::Default;
-
-# The Class::Default package allows a class that inherits from
-# it to act as both an instantiatable and static class.
-
-# See POD for more details.
-
-require 5.005;
-use strict;
-use Carp;
-
-# Define globals
-use vars qw{$VERSION %DEFAULT};
-BEGIN {
- $VERSION = '1.0';
-
- # Create the default object storage.
- %DEFAULT = ();
-}
-
-# Get the default object if we are passed the class name.
-sub _self {
- my $either = shift;
- ref($either) ? $either
- : $DEFAULT{$either}
- || ($DEFAULT{$either} = $either->_create_default_object)
- || croak "Error while creating default object";
-}
-
-# Suplimentary method to reliably get ONLY the class
-sub _class { ref $_[0] or $_[0] }
-
-# Retrieve the default object for a class, either from
-# the cache, or create it new.
-sub _get_default {
- my $class = shift;
- $DEFAULT{$class}
- || ($DEFAULT{$class} = $class->_create_default_object)
- || croak "Error while creating default object";
-}
-
-# Creates the default object.
-# Used to provide options to a constructor to create the default object.
-sub _create_default_object {
- my $class = shift;
-
- ### When you copy this to overload it, you should add
- ### arguments to the constructor call as needed.
-
- # Create the new object.
- my $self = $class->new;
-
- ### Make any modifications to the default object here
-
- $self;
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Class::Default - Static calls apply to a default instantiation
-
-=head1 SYNOPSIS
-
- # Create the defaulted class
- package Foo::Base;
-
- use base 'Class::Default';
-
- sub new { bless {}, $_[0] }
-
- sub show {
- my $self = shift->_self;
- "$self";
- }
-
- # Do something to the default object
-
- package main;
-
- print Foo::Bar->show;
-
- # Prints 'Foo::Bar=HASH(0x80d22f8)'
-
-=head1 DESCRIPTION
-
-Class::Default provides a mechanism to allow your class to take static method
-calls and apply it to a default instantiation of an object. It provides a
-flexibility to an API that allows it to be used more confortably in
-different situations.
-
-A good example of this technique in use is CGI.pm. When you use a static
-method, like C<CGI->header>, your call is being applied to a default
-instantiation of a CGI object.
-
-This technique appears to be especially usefull when writing modules that you
-want to be used in either a single use or a persistant environment. In a CGI
-like environment, you want the simplicity of a static interface. You can
-call C<Class->method> directly, without having to pass an instantiation
-around constantly.
-
-=head1 USING THE MODULES
-
-Class::Default provides a couple of levels of control. They start with simple
-enabling the method to apply to the default instantation, and move on to
-providing some level of control over the creation of the default object.
-
-=head2 Inheriting from Class::Default
-
-To start, you will need to inherit from Class::Default. You do this in the
-normal manner, using something like C<use base 'Class::Default'>, or setting
-the @ISA value directly. C<Class::Default> does not have a default
-constructor or any public methods, so you should be able to use it a
-multiple inheritance situation without any implications.
-
-=head2 Making method work
-
-To make your class work with Class::Default you need to make a small
-adjustment to each method that you would like to be able to access the
-default object.
-
-A typical method will look something like the following
-
- sub foobar {
- my $self = shift;
-
- # Do whatever the method does
- }
-
-To make the method work with Class::Default, you should change it to
-the following
-
- sub foobar {
- my $self = shift->_self;
-
- # Do whatever the method does
- }
-
-This change is very low impact, easy to use, and will not make any other
-differences to the way your code works.
-
-=head2 Control over the default object
-
-When needed, Class::Default will make a new instantation of your class
-and cache it to be used whenever a static call is made. It does this in
-the simplest way possible, by calling C<Class->new()> with no arguments.
-
-This is fine if you have a very pure class that can handle creating a
-new object without any arguments, but many classes expect some sort of
-argument to the the constructor, and indeed that the constructor that
-should be used it the C<new> method.
-
-Enter the C<_create_default_object> method. By overloading the
-C<_create_default_object> method in your class, you can custom create the
-default object. This will used to create the default object on demand, the
-first time a method is called. For example, the following class demonstrate
-the use of C<_create_default_object> to set some values in the default
-object.
-
- package Slashdot::User;
-
- use base 'Class::Default';
-
- # Constructor
- sub new {
- my $class = shift;
- my $name = shift;
-
- my $self = {
- name => $name,
- favourite_color => '',
- };
-
- return bless $self, $class;
- }
-
- # Default constructor
- sub _create_default_object {
- my $class = shift;
-
- my $self = $class->new( 'Anonymous Coward' );
- $self->{favourite_color} = 'Orange';
-
- return $self;
- }
-
- sub name { $_[0]->{name} }
- sub favourite_color { $_[0]->{favourite_color} }
-
-That provides a statically accessible default object that could be used as in
-the following manner.
-
- print "The default slashdot user is " . Slashdot::User->name
- . " and they like the colour " . Slashdot::User->favourite_color;
-
-Remember that the default object is persistant, so changes made to the
-statically accessible object can be recovered later.
-
-=head2 Getting access to the default object
-
-There are a few ways to do this, but the easiest way is to simple do
-the following
-
- my $default = Slashdot::User->_get_default;
-
-=head1 METHODS
-
-=head2 _self
-
-Used by methods to make the method apply to the default object if called
-statically without affecting normal object methods.
-
-=head2 _class
-
-The C<_class> method provides the opposite of the C<_self> method. Instead
-of always getting an object, C<_class> will always get the class name, so
-a method can be guarenteed to run in a static context. This is not
-essential to the use of a C<Class::Default> module, but is provided as a
-convenience.
-
-=head2 _get_default
-
-Used to get the default object directly.
-
-=head2 _create_default_object
-
-To be overloaded by your class to set any properties to the default
-object at creation time.
-
-=head1 BUGS
-
-No known bugs, but suggestions are welcome
-
-=head1 SUPPORT
-
-Contact the author
-
-=head1 AUTHOR
-
- Adam Kennedy
- cpan at ali.as
- http://ali.as/
-
-=head1 SEE ALSO
-
-Class::*
-
-=head1 COPYRIGHT
-
-Copyright (c) 2002 Adam Kennedy. All rights reserved.
-This program is free software; you can redistribute
-it and/or modify it under the same terms as Perl itself.
-
-The full text of the license can be found in the
-LICENSE file included with this module.
-
-=cut
+package Class::Default;
+
+# The Class::Default package allows a class that inherits from
+# it to act as both an instantiatable and static class.
+
+# See POD for more details.
+
+use 5.005;
+use strict;
+use Carp ();
+
+# Define globals
+use vars qw{$VERSION %DEFAULT};
+BEGIN {
+ $VERSION = '1.1';
+
+ # Create the default object storage.
+ %DEFAULT = ();
+}
+
+# Get the default object if we are passed the class name.
+sub _self {
+ my $either = shift;
+ ref($either) ? $either
+ : $DEFAULT{$either}
+ || ($DEFAULT{$either} = $either->_create_default_object)
+ || Carp::croak "Error while creating default object";
+}
+
+# Suplimentary method to reliably get ONLY the class
+sub _class { ref $_[0] or $_[0] }
+
+# Retrieve the default object for a class, either from
+# the cache, or create it new.
+sub _get_default {
+ my $class = shift;
+ $DEFAULT{$class}
+ || ($DEFAULT{$class} = $class->_create_default_object)
+ || Carp::croak "Error while creating default object";
+}
+
+# Creates the default object.
+# Used to provide options to a constructor to create the default object.
+sub _create_default_object {
+ my $class = shift;
+
+ ### When you copy this to overload it, you should add
+ ### arguments to the constructor call as needed.
+
+ # Create the new object.
+ my $self = $class->new;
+
+ ### Make any modifications to the default object here
+
+ $self;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::Default - Static calls apply to a default instantiation
+
+=head1 SYNOPSIS
+
+ # Create the defaulted class
+ package Foo::Base;
+
+ use base 'Class::Default';
+
+ sub new { bless {}, $_[0] }
+
+ sub show {
+ my $self = shift->_self;
+ "$self";
+ }
+
+ # Do something to the default object
+
+ package main;
+
+ print Foo::Bar->show;
+
+ # Prints 'Foo::Bar=HASH(0x80d22f8)'
+
+=head1 DESCRIPTION
+
+Class::Default provides a mechanism to allow your class to take static method
+calls and apply it to a default instantiation of an object. It provides a
+flexibility to an API that allows it to be used more confortably in
+different situations.
+
+A good example of this technique in use is CGI.pm. When you use a static
+method, like C<CGI->header>, your call is being applied to a default
+instantiation of a CGI object.
+
+This technique appears to be especially usefull when writing modules that you
+want to be used in either a single use or a persistant environment. In a CGI
+like environment, you want the simplicity of a static interface. You can
+call C<Class->method> directly, without having to pass an instantiation
+around constantly.
+
+=head1 USING THE MODULES
+
+Class::Default provides a couple of levels of control. They start with simple
+enabling the method to apply to the default instantation, and move on to
+providing some level of control over the creation of the default object.
+
+=head2 Inheriting from Class::Default
+
+To start, you will need to inherit from Class::Default. You do this in the
+normal manner, using something like C<use base 'Class::Default'>, or setting
+the @ISA value directly. C<Class::Default> does not have a default
+constructor or any public methods, so you should be able to use it a
+multiple inheritance situation without any implications.
+
+=head2 Making method work
+
+To make your class work with Class::Default you need to make a small
+adjustment to each method that you would like to be able to access the
+default object.
+
+A typical method will look something like the following
+
+ sub foobar {
+ my $self = shift;
+
+ # Do whatever the method does
+ }
+
+To make the method work with Class::Default, you should change it to
+the following
+
+ sub foobar {
+ my $self = shift->_self;
+
+ # Do whatever the method does
+ }
+
+This change is very low impact, easy to use, and will not make any other
+differences to the way your code works.
+
+=head2 Control over the default object
+
+When needed, Class::Default will make a new instantation of your class
+and cache it to be used whenever a static call is made. It does this in
+the simplest way possible, by calling C<Class->new()> with no arguments.
+
+This is fine if you have a very pure class that can handle creating a
+new object without any arguments, but many classes expect some sort of
+argument to the the constructor, and indeed that the constructor that
+should be used it the C<new> method.
+
+Enter the C<_create_default_object> method. By overloading the
+C<_create_default_object> method in your class, you can custom create the
+default object. This will used to create the default object on demand, the
+first time a method is called. For example, the following class demonstrate
+the use of C<_create_default_object> to set some values in the default
+object.
+
+ package Slashdot::User;
+
+ use base 'Class::Default';
+
+ # Constructor
+ sub new {
+ my $class = shift;
+ my $name = shift;
+
+ my $self = {
+ name => $name,
+ favourite_color => '',
+ };
+
+ return bless $self, $class;
+ }
+
+ # Default constructor
+ sub _create_default_object {
+ my $class = shift;
+
+ my $self = $class->new( 'Anonymous Coward' );
+ $self->{favourite_color} = 'Orange';
+
+ return $self;
+ }
+
+ sub name { $_[0]->{name} }
+ sub favourite_color { $_[0]->{favourite_color} }
+
+That provides a statically accessible default object that could be used as in
+the following manner.
+
+ print "The default slashdot user is " . Slashdot::User->name
+ . " and they like the colour " . Slashdot::User->favourite_color;
+
+Remember that the default object is persistant, so changes made to the
+statically accessible object can be recovered later.
+
+=head2 Getting access to the default object
+
+There are a few ways to do this, but the easiest way is to simple do
+the following
+
+ my $default = Slashdot::User->_get_default;
+
+=head1 METHODS
+
+=head2 _self
+
+Used by methods to make the method apply to the default object if called
+statically without affecting normal object methods.
+
+=head2 _class
+
+The C<_class> method provides the opposite of the C<_self> method. Instead
+of always getting an object, C<_class> will always get the class name, so
+a method can be guarenteed to run in a static context. This is not
+essential to the use of a C<Class::Default> module, but is provided as a
+convenience.
+
+=head2 _get_default
+
+Used to get the default object directly.
+
+=head2 _create_default_object
+
+To be overloaded by your class to set any properties to the default
+object at creation time.
+
+=head1 BUGS
+
+No known bugs, but suggestions are welcome
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class%3ADefault>
+
+Contact the author
+
+=head1 AUTHOR
+
+Adam Kennedy (Maintainer), L<http://ali.as/>, cpan at ali.as
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002 Adam Kennedy. All rights reserved.
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
Added: packages/libclass-default-perl/branches/upstream/current/t/00_compile.t
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/t/00_compile.t 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/t/00_compile.t 2005-01-10 14:09:42 UTC (rev 604)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl -w
+
+# Load testing for Class::Default
+
+use strict;
+use lib ();
+use UNIVERSAL 'isa';
+use File::Spec::Functions ':ALL';
+BEGIN {
+ $| = 1;
+ unless ( $ENV{HARNESS_ACTIVE} ) {
+ require FindBin;
+ chdir ($FindBin::Bin = $FindBin::Bin); # Avoid a warning
+ lib->import( catdir( updir(), updir(), 'modules') );
+ }
+}
+
+use Test::More tests => 2;
+
+# Check their perl version
+ok( $] >= 5.005, "Your perl is new enough" );
+
+# Does the module load
+use_ok('Class::Default');
+
+exit(0);
Modified: packages/libclass-default-perl/branches/upstream/current/t/01_main.t
===================================================================
--- packages/libclass-default-perl/branches/upstream/current/t/01_main.t 2005-01-07 19:26:47 UTC (rev 603)
+++ packages/libclass-default-perl/branches/upstream/current/t/01_main.t 2005-01-10 14:09:42 UTC (rev 604)
@@ -2,19 +2,24 @@
# Formal testing for Class::Default
-# Do all the tests on ourself, since we know we will be loaded.
-
use strict;
+use lib ();
use UNIVERSAL 'isa';
-use File::Spec::Functions qw{:ALL};
-use lib catdir( updir(), updir(), 'modules' ), # Development testing
- catdir( updir(), 'lib' ); # For installation testing
-use Test::More tests => 22;
+use File::Spec::Functions ':ALL';
+BEGIN {
+ $| = 1;
+ unless ( $ENV{HARNESS_ACTIVE} ) {
+ require FindBin;
+ chdir ($FindBin::Bin = $FindBin::Bin); # Avoid a warning
+ lib->import( catdir( updir(), updir(), 'modules') );
+ }
+}
+use Test::More tests => 20;
+
# Set up any needed globals
use vars qw{$cd $cdt};
BEGIN {
- $| = 1;
$cd = 'Class::Default';
$cdt = 'Class::Default::Test1';
}
@@ -22,26 +27,52 @@
-# Check their perl version
-BEGIN {
- ok( $] >= 5.005, "Your perl is new enough" );
-}
+# Basic API existance
+ok( Class::Default->can( '_self' ), "Class::Default->_self exists" );
+ok( Class::Default->can( '_get_default' ), "Class::Default->_get_default exists" );
+ok( Class::Default->can( '_create_default_object' ), "Class::Default->_create_default_object exists" );
+ok( Class::Default::Test1->can( '_self' ), "Class::Default::Test1->_self exists" );
+ok( Class::Default::Test1->can( '_get_default' ), "Class::Default::Test1->_get_default exists" );
+ok( Class::Default::Test1->can( '_create_default_object' ),
+ "Class::Default::Test1->_create_default_object exists" );
+# Object gets created...
+my $object = Class::Default::Test1->new();
+ok( isa( $object, "Class::Default::Test1" ), "Object isa Class::Default::Test1" );
+ok( isa( $object, "Class::Default" ), "Object isa Class::Default" );
+ok( ! scalar keys %Class::Default::DEFAULT, "DEFAULT hash remains empty after normal object creation" );
+# Default gets created
+my $default1 = Class::Default::Test1->_get_default;
+ok( $default1, "->_get_default returns something" );
+ok( (ref $default1 eq $cdt), "->_get_default returns the correct object type" );
+ok( scalar keys %Class::Default::DEFAULT, "DEFAULT hash contains something after _get_default" );
+ok( (scalar keys %Class::Default::DEFAULT == 1), "DEFAULT hash contains only one thing after _get_default" );
+ok( exists $Class::Default::DEFAULT{$cdt}, "DEFAULT hash contains the correct key after _get_Default" );
+ok( "$Class::Default::DEFAULT{$cdt}" eq "$default1",
+ "DEFAULT hash entry matches that returned" );
+# Get another object and see if they match
+my $default2 = Class::Default::Test1->_get_default;
+ok( "$default1" eq "$default2", "Second object matches the first object" );
-# Does the module load
-use_ok( 'Class::Default' );
+# Check the response of a typical method as compared to the static
+ok( $object->hash eq "$object", "Result of basic object method matchs" );
+ok( Class::Default::Test1->hash eq "$default1", "Result of basic static method matchs" );
+# Check the result of the _class method
+ok( Class::Default::Test1->class eq 'Class::Default::Test1', "Static ->_class returns the class" );
+ok( $default1->class eq 'Class::Default::Test1', "Object ->_class returns the class" );
-# Create the test package
-package Class::Default::Test1;
-use strict;
+
+# Define the testing package
+package Class::Default::Test1;
+
use base 'Class::Default';
sub new {
@@ -74,46 +105,3 @@
}
1;
-
-package main;
-
-
-
-
-
-# Basic API existance
-ok( Class::Default->can( '_self' ), "Class::Default->_self exists" );
-ok( Class::Default->can( '_get_default' ), "Class::Default->_get_default exists" );
-ok( Class::Default->can( '_create_default_object' ), "Class::Default->_create_default_object exists" );
-ok( Class::Default::Test1->can( '_self' ), "Class::Default::Test1->_self exists" );
-ok( Class::Default::Test1->can( '_get_default' ), "Class::Default::Test1->_get_default exists" );
-ok( Class::Default::Test1->can( '_create_default_object' ),
- "Class::Default::Test1->_create_default_object exists" );
-
-# Object gets created...
-my $object = Class::Default::Test1->new();
-ok( isa( $object, "Class::Default::Test1" ), "Object isa Class::Default::Test1" );
-ok( isa( $object, "Class::Default" ), "Object isa Class::Default" );
-ok( ! scalar keys %Class::Default::DEFAULT, "DEFAULT hash remains empty after normal object creation" );
-
-# Default gets created
-my $default1 = Class::Default::Test1->_get_default;
-ok( $default1, "->_get_default returns something" );
-ok( (ref $default1 eq $cdt), "->_get_default returns the correct object type" );
-ok( scalar keys %Class::Default::DEFAULT, "DEFAULT hash contains something after _get_default" );
-ok( (scalar keys %Class::Default::DEFAULT == 1), "DEFAULT hash contains only one thing after _get_default" );
-ok( exists $Class::Default::DEFAULT{$cdt}, "DEFAULT hash contains the correct key after _get_Default" );
-ok( "$Class::Default::DEFAULT{$cdt}" eq "$default1",
- "DEFAULT hash entry matches that returned" );
-
-# Get another object and see if they match
-my $default2 = Class::Default::Test1->_get_default;
-ok( "$default1" eq "$default2", "Second object matches the first object" );
-
-# Check the response of a typical method as compared to the static
-ok( $object->hash eq "$object", "Result of basic object method matchs" );
-ok( Class::Default::Test1->hash eq "$default1", "Result of basic static method matchs" );
-
-# Check the result of the _class method
-ok( Class::Default::Test1->class eq 'Class::Default::Test1', "Static ->_class returns the class" );
-ok( $default1->class eq 'Class::Default::Test1', "Object ->_class returns the class" );
More information about the Pkg-perl-cvs-commits
mailing list