r2424 - in packages/libhttp-server-simple-perl/branches/upstream/current: . inc/Module inc/Module/Install lib/HTTP/Server lib/HTTP/Server/Simple/CGI

Niko Tyni ntyni-guest at costa.debian.org
Fri Mar 17 22:39:13 UTC 2006


Author: ntyni-guest
Date: 2006-03-17 22:39:12 +0000 (Fri, 17 Mar 2006)
New Revision: 2424

Modified:
   packages/libhttp-server-simple-perl/branches/upstream/current/Changes
   packages/libhttp-server-simple-perl/branches/upstream/current/META.yml
   packages/libhttp-server-simple-perl/branches/upstream/current/SIGNATURE
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Base.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Can.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Makefile.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Metadata.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple.pm
   packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple/CGI/Environment.pm
Log:
Load /tmp/tmp.UcoRnx/libhttp-server-simple-perl-0.18 into
packages/libhttp-server-simple-perl/branches/upstream/current.


Modified: packages/libhttp-server-simple-perl/branches/upstream/current/Changes
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/Changes	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/Changes	2006-03-17 22:39:12 UTC (rev 2424)
@@ -1,3 +1,12 @@
+0.18
+
+  new method: valid_http_method() from Chris Dent to make it easier to 
+  create servers handling non-standard HTTP verbs.
+
+0.17
+  Workaround for Class::Spiffy classloading order issue
+  Better handling for completely mangled requests.
+
 0.16 Mon Nov  7 14:40:43 EST 2005
 
   SIG{'HUP'} does not exist on Win32 (cpan #15606)

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/META.yml	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/META.yml	2006-03-17 22:39:12 UTC (rev 2424)
@@ -1,12 +1,13 @@
+distribution_type: module
+generated_by: Module::Install version 0.52
+license: perl
 name: HTTP-Server-Simple
-version: 0.16
-license: perl
-distribution_type: module
+no_index:
+  directory:
+    - inc
+    - t
 requires:
+  CGI: 0
   Socket: 0
   Test::More: 0
-  CGI: 0
-no_index:
-  directory:
-    - inc
-generated_by: Module::Install version 0.37
+version: 0.18

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/SIGNATURE
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/SIGNATURE	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/SIGNATURE	2006-03-17 22:39:12 UTC (rev 2424)
@@ -14,23 +14,23 @@
 -----BEGIN PGP SIGNED MESSAGE-----
 Hash: SHA1
 
-SHA1 26bb64f3864e5f6784401a38e226aa1ddd73edde Changes
+SHA1 5fb9209da2f06d0bf15387dafcac44f8c53aa06f Changes
 SHA1 0ac508c50476dcc2bf8fe3094cb341425291e1ee MANIFEST
-SHA1 ecbd933c6b8e7d47e41fc16c3f21c8df92fa2c3f META.yml
+SHA1 51a91151f855b6d04d73b0611ab2d3c498bfa1c7 META.yml
 SHA1 490f3fd115e09cb05b725580e5ed5cdd58241049 Makefile.PL
 SHA1 ed0c107672daac3bc9e266876666e1059dbe44b7 README
 SHA1 4ea1e9072ca87399184a46233df52a21e285604d ex/sample_server
-SHA1 842ab7e28834effb9e4222aab72c4106727dea0f inc/Module/Install.pm
-SHA1 1da4fc271065900f73682f31d4f9c0dae5288143 inc/Module/Install/Base.pm
-SHA1 0d0b6772bd5ec750e99d238942c88329e394d48d inc/Module/Install/Can.pm
+SHA1 e8ed0773fed846d6f5480bf3bf1735c2d551da63 inc/Module/Install.pm
+SHA1 9dbed9ff1790473ec3136a606f062fa050326c43 inc/Module/Install/Base.pm
+SHA1 d37430abee4687a4861b1312e5bea6953e6afe4d inc/Module/Install/Can.pm
 SHA1 a784ba7d2b096084b2ffed3a7d853e2847f4dedb inc/Module/Install/Fetch.pm
-SHA1 dc2af04175831ddb9a00de944e761e5c46bbf283 inc/Module/Install/Makefile.pm
-SHA1 421da5922ad85b72ae5b27c33803e86b3762d238 inc/Module/Install/Metadata.pm
+SHA1 044cd2f160364fe36eca2ba35e16e7cf46c79138 inc/Module/Install/Makefile.pm
+SHA1 49e0d839edeb0f3e9af12fd2444b98365393a23e inc/Module/Install/Metadata.pm
 SHA1 2a1b494a7e5adaa3216e86d909dd5bf87d084c80 inc/Module/Install/Win32.pm
-SHA1 c92e1d32922615347e059e7e3a2f53b5e9c98e3b inc/Module/Install/WriteAll.pm
-SHA1 f6b00458452368320b19750392487cf1e8515c1b lib/HTTP/Server/Simple.pm
+SHA1 4a23fafe534363a99f0d936df9086ad243e692c9 inc/Module/Install/WriteAll.pm
+SHA1 6c1a08a64406bdf937a0996d1803286df7a223f6 lib/HTTP/Server/Simple.pm
 SHA1 2d7348b166f654a460ddae4cb4183f4a544c85fc lib/HTTP/Server/Simple/CGI.pm
-SHA1 b2c2d007a7f50058c874e633d15fb621b2bfc394 lib/HTTP/Server/Simple/CGI/Environment.pm
+SHA1 27c4b8c97f00d3427a320c8087e2b77b128a1992 lib/HTTP/Server/Simple/CGI/Environment.pm
 SHA1 db064af54cab345a71daec576e32e64b8fb1033d t/00smoke.t
 SHA1 9e68bffc26b5a42e2785ec68c3bf6fe45d6bb6da t/01live.t
 SHA1 aca95653cfce68912e08c57b3a4566207e2f99b3 t/02pod.t
@@ -39,7 +39,7 @@
 -----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1.4.1 (GNU/Linux)
 
-iD8DBQFDb63XEi9d9xCOQEYRArQVAJ44Bkj2jqybBIr71mclQ0aOi/u2cgCgkakh
-e210lVUgdouYs0xX1F+CElo=
-=odXJ
+iD8DBQFD6qfhEi9d9xCOQEYRAjyLAKCLKcijRrqA9NW7JZkfnOVlHuxifwCeMZuU
+nrm1Jro4k1y4NyyOj9r7ee8=
+=K+Ut
 -----END PGP SIGNATURE-----

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Base.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Base.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Base.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -1,8 +1,11 @@
 #line 1 "inc/Module/Install/Base.pm - /usr/local/share/perl/5.8.7/Module/Install/Base.pm"
 package Module::Install::Base;
 
-#line 28
+# Suspend handler for "redefined" warnings
+BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w } };
 
+#line 30
+
 sub new {
     my ($class, %args) = @_;
 
@@ -15,18 +18,21 @@
     bless(\%args, $class);
 }
 
-#line 46
+#line 48
 
 sub AUTOLOAD {
     my $self = shift;
-    goto &{$self->_top->autoload};
+
+    local $@;
+    my $autoload = eval { $self->_top->autoload } or return;
+    goto &$autoload;
 }
 
-#line 57
+#line 62
 
 sub _top { $_[0]->{_top} }
 
-#line 68
+#line 73
 
 sub admin {
     my $self = shift;
@@ -49,6 +55,9 @@
 
 1;
 
+# Restore warning handler
+BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->() };
+
 __END__
 
-#line 112
+#line 120

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Can.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Can.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Can.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -8,6 +8,20 @@
 use File::Spec ();
 use ExtUtils::MakeMaker ();
 
+# check if we can load some module
+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) = @_;
@@ -35,4 +49,21 @@
     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) {
+                ExtUtils::MM_Win32->maybe_command($file);
+            }
+            else {
+                $self->SUPER::maybe_command($file);
+            }
+        }
+    }
+}
+
 1;

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Makefile.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Makefile.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Makefile.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -23,6 +23,14 @@
     $args;
 }
 
+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} ||= {};
@@ -53,17 +61,18 @@
     $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
     $args->{VERSION} = $self->version || $self->determine_VERSION($args);
     $args->{NAME} =~ s/-/::/g;
-    $args->{test} = {TESTS => $self->tests};
 
+    $args->{test} = {TESTS => $self->tests} if $self->tests;
+
     if ($] >= 5.005) {
-	$args->{ABSTRACT} = $self->abstract;
-	$args->{AUTHOR} = $self->author;
+        $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;
+        $args->{SIGN} = 1 if $self->sign;
     }
     delete $args->{SIGN} unless $self->is_admin;
 
@@ -73,10 +82,13 @@
                  ($self->build_requires, $self->requires) );
 
     # merge both kinds of requires into prereq_pm
-    my $dir = ($args->{DIR} ||= []);
+    my $subdirs = ($args->{DIR} ||= []);
     if ($self->bundles) {
-        push @$dir, map "$_->[1]", @{$self->bundles};
-        delete $prereq->{$_->[0]} for @{$self->bundles};
+        foreach my $bundle (@{ $self->bundles }) {
+            my ($file, $dir) = @$bundle;
+            push @$subdirs, $dir if -d $dir;
+            delete $prereq->{$file};
+        }
     }
 
     if (my $perl_version = $self->perl_version) {
@@ -107,6 +119,7 @@
     my $postamble = "# Postamble by $top_class $top_version\n" . 
                     ($self->postamble || '');
 
+    local *MAKEFILE;
     open MAKEFILE, '< Makefile' or die $!;
     my $makefile = do { local $/; <MAKEFILE> };
     close MAKEFILE;
@@ -141,4 +154,4 @@
 
 __END__
 
-#line 274
+#line 286

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Metadata.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Metadata.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/Metadata.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -1,25 +1,33 @@
 #line 1 "inc/Module/Install/Metadata.pm - /usr/local/share/perl/5.8.7/Module/Install/Metadata.pm"
 package Module::Install::Metadata;
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
 
-$VERSION = '0.04';
-
 use strict 'vars';
-use vars qw($VERSION);
+use Module::Install::Base;
 
-sub Meta { shift }
+use vars qw($VERSION @ISA);
+BEGIN {
+    $VERSION = '0.06';
+    @ISA     = 'Module::Install::Base';
+}
 
-my @scalar_keys = qw(
-    name module_name version abstract author license
-    distribution_type sign perl_version tests
-);
-my @tuple_keys  = qw(build_requires requires recommends bundles);
+my @scalar_keys = qw{
+    name module_name abstract author version license
+    distribution_type perl_version tests
+};
 
+my @tuple_keys = qw{
+    build_requires requires recommends bundles
+};
+
+sub Meta            { shift        }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys  { @tuple_keys  }
+
 foreach my $key (@scalar_keys) {
     *$key = sub {
         my $self = shift;
-        return $self->{'values'}{$key} unless @_;
-        $self->{'values'}{$key} = shift;
+        return $self->{values}{$key} if defined wantarray and !@_;
+        $self->{values}{$key} = shift;
         return $self;
     };
 }
@@ -27,122 +35,152 @@
 foreach my $key (@tuple_keys) {
     *$key = sub {
         my $self = shift;
-        return $self->{'values'}{$key} unless @_;
+        return $self->{values}{$key} unless @_;
+
         my @rv;
         while (@_) {
-            my $module  = shift or last;
+            my $module = shift or last;
             my $version = shift || 0;
-            if ($module eq 'perl') {
+            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;
+            my $rv = [ $module, $version ];
             push @rv, $rv;
         }
-        return @rv;
+        push @{ $self->{values}{$key} }, @rv;
+        @rv;
     };
 }
 
-sub features {
+sub sign {
     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'}{'sign'} if defined wantarray and !@_;
+    $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+    return $self;
+}
+
+sub all_from {
+    my ( $self, $file ) = @_;
+
+    unless ( defined($file) ) {
+        my $name = $self->name
+            or die "all_from called with no args without setting name() first";
+        $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+        $file =~ s{.*/}{} unless -e $file;
+        die "all_from: cannot find $file from $name" unless -e $file;
     }
-    return @{$self->{'values'}{'features'}};
+
+    $self->version_from($file)      unless $self->version;
+    $self->perl_version_from($file) unless $self->perl_version;
+
+    # The remaining probes read from POD sections; if the file
+    # has an accompanying .pod, use that instead
+    my $pod = $file;
+    if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+        $file = $pod;
+    }
+
+    $self->author_from($file)   unless $self->author;
+    $self->license_from($file)  unless $self->license;
+    $self->abstract_from($file) unless $self->abstract;
 }
 
-sub no_index {
-    my $self = shift;
-    my $type = shift;
-    push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type;
-    return $self->{'values'}{'no_index'};
+sub provides {
+    my $self     = shift;
+    my $provides = ( $self->{values}{provides} ||= {} );
+    %$provides = (%$provides, @_) if @_;
+    return $provides;
 }
 
-sub _dump {
+sub auto_provides {
     my $self = shift;
-    my $package = ref($self->_top);
-    my $version = $self->_top->VERSION;
-    my %values = %{$self->{'values'}};
+    return $self unless $self->is_admin;
 
-    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}||[]},
-        ];
+    unless (-e 'MANIFEST') {
+        warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+        return $self;
     }
 
-    warn "No license specified, setting license = 'unknown'\n"
-        unless $values{license};
+    # Avoid spurious warnings as we are not checking manifest here.
 
-    $values{license} ||= 'unknown';
-    $values{distribution_type} ||= 'module';
-    $values{name} ||= do {
-        my $name = $values{module_name};
-        $name =~ s/::/-/g;
-        $name;
-    } if $values{module_name};
+    local $SIG{__WARN__} = sub {1};
+    require ExtUtils::Manifest;
+    local *ExtUtils::Manifest::manicheck = sub { return };
 
-    if ($values{name} =~ /::/) {
-        my $name = $values{name};
-        $name =~ s/::/-/g;
-        die "Error in name(): '$values{name}' should be '$name'!\n";
-    }
+    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 || {} });
+}
 
-    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";
-        }
-    }
+sub feature {
+    my $self     = shift;
+    my $name     = shift;
+    my $features = ( $self->{values}{features} ||= [] );
 
-    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});
+    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 {
-        $dump .= << "META";
-no_index:
-  directory:
-    - inc
-META
+        $mods = \@_;
     }
-    
-    $dump .= "generated_by: $package version $version\n";
-    return $dump;
+
+    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} };
+}
+
+sub no_index {
+    my $self = shift;
+    my $type = shift;
+    push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+    return $self->{values}{no_index};
+}
+
 sub read {
     my $self = shift;
     $self->include_deps( 'YAML', 0 );
+
     require YAML;
-    my $data = YAML::LoadFile( 'META.yml' );
+    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 );
+    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->$key( $value );
+            $self->can($key)->($self, $value);
         }
     }
     return $self;
@@ -151,37 +189,113 @@
 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;
+    $self->admin->write_meta;
     return $self;
 }
 
 sub version_from {
-    my ($self, $version_from) = @_;
+    my ( $self, $file ) = @_;
     require ExtUtils::MM_Unix;
-    $self->version(ExtUtils::MM_Unix->parse_version($version_from));
+    $self->version( ExtUtils::MM_Unix->parse_version($file) );
 }
 
 sub abstract_from {
-    my ($self, $abstract_from) = @_;
+    my ( $self, $file ) = @_;
     require ExtUtils::MM_Unix;
     $self->abstract(
-        bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix')
-            ->parse_abstract($abstract_from)
-    );
+        bless(
+            { DISTNAME => $self->name },
+            'ExtUtils::MM_Unix'
+        )->parse_abstract($file)
+     );
 }
 
+sub _slurp {
+    my ( $self, $file ) = @_;
+
+    local *FH;
+    open FH, "< $file" or die "Cannot open $file.pod: $!";
+    do { local $/; <FH> };
+}
+
+sub perl_version_from {
+    my ( $self, $file ) = @_;
+
+    if (
+        $self->_slurp($file) =~ m/
+        ^
+        use \s*
+        v?
+        ([\d\.]+)
+        \s* ;
+    /ixms
+      )
+    {
+        $self->perl_version($1);
+    }
+    else {
+        warn "Cannot determine perl version info from $file\n";
+        return;
+    }
+}
+
+sub author_from {
+    my ( $self, $file ) = @_;
+    my $content = $self->_slurp($file);
+    if ($content =~ m/
+        =head \d \s+ (?:authors?)\b \s*
+        ([^\n]*)
+        |
+        =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+        .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+        ([^\n]*)
+    /ixms) {
+        my $author = $1 || $2;
+        $author =~ s{E<lt>}{<}g;
+        $author =~ s{E<gt>}{>}g;
+        $self->author($author); 
+    }
+    else {
+        warn "Cannot determine author info from $file\n";
+    }
+}
+
+sub license_from {
+    my ( $self, $file ) = @_;
+
+    if (
+        $self->_slurp($file) =~ m/
+        =head \d \s+
+        (?:licen[cs]e|licensing|copyright|legal)\b
+        (.*?)
+        (=head\\d.*|=cut.*|)
+        \z
+    /ixms
+      )
+    {
+        my $license_text = $1;
+        my @phrases      = (
+            'under the same (?:terms|license) as perl itself' => 'perl',
+            'GNU public license'                              => 'gpl',
+            'GNU lesser public license'                       => 'gpl',
+            'BSD license'                                     => 'bsd',
+            'Artistic license'                                => 'artistic',
+            'GPL'                                             => 'gpl',
+            'LGPL'                                            => 'lgpl',
+            'BSD'                                             => 'bsd',
+            'Artistic'                                        => 'artistic',
+        );
+        while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
+            $pattern =~ s{\s+}{\\s+}g;
+            if ( $license_text =~ /\b$pattern\b/i ) {
+                $self->license($license);
+                return 1;
+            }
+        }
+    }
+
+    warn "Cannot determine license info from $file\n";
+    return 'unknown';
+}
+
 1;

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install/WriteAll.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -5,9 +5,9 @@
 sub WriteAll {
     my $self = shift;
     my %args = (
-        meta => 1,
-        sign => 0,
-        inline => 0,
+        meta        => 1,
+        sign        => 0,
+        inline      => 0,
         check_nmake => 1,
         @_
     );
@@ -17,10 +17,10 @@
     $self->admin->WriteAll(%args) if $self->is_admin;
 
     if ($0 =~ /Build.PL$/i) {
-	$self->Build->write;
+        $self->Build->write;
     }
     else {
-	$self->check_nmake if $args{check_nmake};
+        $self->check_nmake if $args{check_nmake};
         $self->makemaker_args( PL_FILES => {} )
             unless $self->makemaker_args->{'PL_FILES'};
 

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/inc/Module/Install.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -1,8 +1,17 @@
-#line 1 "inc/Module/Install.pm - /usr/local/share/perl/5.8.7/Module/Install.pm"
+#line 1 "/home/jesse/svk/HTTP-Server-Simple/inc/Module/Install.pm - /usr/local/share/perl/5.8.7/Module/Install.pm"
 package Module::Install;
-$VERSION = '0.37';
 
-die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'};
+use 5.004;
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+    # Don't forget to update Module::Install::Admin too!
+    $VERSION = '0.52';
+}
+
+# inc::Module::Install must be loaded first
+unless ( $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'} ) {
+    die <<"END_DIE";
 Please invoke ${\__PACKAGE__} with:
 
     use inc::${\__PACKAGE__};
@@ -11,23 +20,40 @@
 
     use ${\__PACKAGE__};
 
-.
+END_DIE
+}
 
-use strict 'vars';
-use Cwd ();
+use Cwd        ();
+use FindBin;
 use File::Find ();
 use File::Path ();
 
- at inc::Module::Install::ISA = 'Module::Install';
 *inc::Module::Install::VERSION = *VERSION;
+ at inc::Module::Install::ISA     = 'Module::Install';
 
-#line 130
+sub autoload {
+    my $self   = shift;
+    my $caller = $self->_caller;
+    my $cwd    = Cwd::cwd();
+    my $sym    = "$caller\::AUTOLOAD";
 
+    $sym->{$cwd} = sub {
+        my $pwd = Cwd::cwd();
+        if ( my $code = $sym->{$pwd} ) {
+            # delegate back to parent dirs
+            goto &$code unless $cwd eq $pwd;
+        }
+        $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller - $sym";
+        unshift @_, ($self, $1);
+        goto &{$self->can('call')} unless uc($1) eq $1;
+    };
+}
+
 sub import {
     my $class = shift;
-    my $self = $class->new(@_);
+    my $self  = $class->new(@_);
 
-    if (not -f $self->{file}) {
+    unless ( -f $self->{file} ) {
         require "$self->{path}/$self->{dispatch}.pm";
         File::Path::mkpath("$self->{prefix}/$self->{author}");
         $self->{admin} = 
@@ -37,44 +63,64 @@
         goto &{"$self->{name}::import"};
     }
 
-    *{caller(0) . "::AUTOLOAD"} = $self->autoload;
+    *{$self->_caller . "::AUTOLOAD"} = $self->autoload;
+    $self->preload;
 
     # Unregister loader and worker packages so subdirs can use them again
     delete $INC{"$self->{file}"};
     delete $INC{"$self->{path}.pm"};
 }
 
-#line 157
+sub preload {
+    my ($self) = @_;
 
-sub autoload {
-    my $self = shift;
-    my $caller = caller;
+        unless ( $self->{extentions} ) {
+                $self->load_extensions(
+                        "$self->{prefix}/$self->{path}", $self
+                        );
+        }
 
-    my $cwd = Cwd::cwd();
-    my $sym = "$caller\::AUTOLOAD";
+    my @exts = @{$self->{extensions}};
+    unless ( @exts ) {
+        my $admin = $self->{admin};
+        @exts = $admin->load_all_extensions;
+    }
 
-    $sym->{$cwd} = sub {
-        my $pwd = Cwd::cwd();
-        if (my $code = $sym->{$pwd}) {
-            goto &$code unless $cwd eq $pwd; # delegate back to parent dirs
+    my %seen_method;
+    foreach my $obj ( @exts ) {
+        while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+            next unless defined *{$glob}{CODE};
+            next if $method =~ /^_/;
+            next if $method eq uc($method);
+            $seen_method{$method}++;
         }
-        $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller";
-        unshift @_, ($self, $1);
-        goto &{$self->can('call')} unless uc($1) eq $1;
-    };
+    }
+
+    my $caller = $self->_caller;
+    foreach my $name (sort keys %seen_method) {
+        *{"${caller}::$name"} = sub {
+            ${"${caller}::AUTOLOAD"} = "${caller}::$name";
+            goto &{"${caller}::AUTOLOAD"};
+        };
+    }
 }
 
-#line 182
-
 sub new {
     my ($class, %args) = @_;
 
+    # ignore the prefix on extension modules built from top level.
+    my $base_path = Cwd::abs_path($FindBin::Bin);
+    unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+        delete $args{prefix};
+    }
+
     return $args{_self} if $args{_self};
 
     $args{dispatch} ||= 'Admin';
     $args{prefix}   ||= 'inc';
     $args{author}   ||= '.author';
     $args{bundle}   ||= 'inc/BUNDLES';
+    $args{base}     ||= $base_path;
 
     $class =~ s/^\Q$args{prefix}\E:://;
     $args{name}     ||= $class;
@@ -84,24 +130,20 @@
         $args{path}  = $args{name};
         $args{path}  =~ s!::!/!g;
     }
-    $args{file}     ||= "$args{prefix}/$args{path}.pm";
+    $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 
     bless(\%args, $class);
 }
 
-#line 211
-
 sub call {
     my $self   = shift;
     my $method = shift;
-    my $obj = $self->load($method) or return;
+    my $obj    = $self->load($method) or return;
 
     unshift @_, $obj;
     goto &{$obj->can($method)};
 }
 
-#line 226
-
 sub load {
     my ($self, $method) = @_;
 
@@ -113,10 +155,10 @@
         return $obj if $obj->can($method);
     }
 
-    my $admin = $self->{admin} or die << "END";
+    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
+END_DIE
 
     my $obj = $admin->load($method, 1);
     push @{$self->{extensions}}, $obj;
@@ -124,8 +166,6 @@
     $obj;
 }
 
-#line 256
-
 sub load_extensions {
     my ($self, $path, $top_obj) = @_;
 
@@ -137,33 +177,46 @@
         my ($file, $pkg) = @{$rv};
         next if $self->{pathnames}{$pkg};
 
-        eval { require $file; 1 } or (warn($@), next);
+        local $@;
+        my $new = eval { require $file; $pkg->can('new') };
+        unless ( $new ) {
+            warn $@ if $@;
+            next;
+        }
         $self->{pathnames}{$pkg} = delete $INC{$file};
-        push @{$self->{extensions}}, $pkg->new( _top => $top_obj );
+        push @{$self->{extensions}}, &{$new}($pkg, _top => $top_obj );
     }
+
+    $self->{extensions} ||= [];
 }
 
-#line 280
-
 sub find_extensions {
     my ($self, $path) = @_;
+
     my @found;
-
-    File::Find::find(sub {
+    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;
+        push @found, [ $file, $pkg ];
+    }, $path ) if -d $path;
 
     @found;
 }
 
-1;
+sub _caller {
+    my $depth  = 0;
+    my $caller = caller($depth);
 
-__END__
+    while ($caller eq __PACKAGE__) {
+        $depth++;
+        $caller = caller($depth);
+    }
 
-#line 618
+    $caller;
+}
+
+1;

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple/CGI/Environment.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple/CGI/Environment.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple/CGI/Environment.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -3,6 +3,7 @@
 
 use strict;
 use warnings;
+use HTTP::Server::Simple;
 
 our $VERSION = $HTTP::Server::Simple::VERSION;
 

Modified: packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple.pm
===================================================================
--- packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple.pm	2006-03-17 22:36:51 UTC (rev 2423)
+++ packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple.pm	2006-03-17 22:39:12 UTC (rev 2424)
@@ -5,7 +5,7 @@
 use Socket;
 use Carp;
 
-our $VERSION = '0.16';
+our $VERSION = '0.18';
 
 =head1 NAME
 
@@ -287,19 +287,19 @@
         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 
-        my ( $method, $request_uri, $proto ) = $self->parse_request
-            or do { $self->bad_request; return };
+        my ( $method, $request_uri, $proto ) = $self->parse_request;
+        
+        
+        unless ($self->valid_http_method($method) ) {
+            $self->bad_request;
+            return;
+        }
 
         $proto ||= "HTTP/0.9";
 
         my ( $file, $query_string )
             = ( $request_uri =~ /([^?]*)(?:\?(.*))?/ );    # split at ?
 
-        if ( $method !~ /^(?:GET|POST|HEAD)$/ ) {
-            $self->bad_request;
-            return;
-        }
-
         $self->setup(
             method       => $method,
             protocol     => $proto,
@@ -603,9 +603,22 @@
         length($bad_request_doc), "\r\n\r\n", $bad_request_doc;
 }
 
+=head2 valid_http_method($method)
+
+Given a candidate HTTP method in $method, determine if it is valid.
+Override if, for example, you'd like to do some WebDAV.
+
+=cut 
+
+sub valid_http_method {
+    my $self   = shift;
+    my $method = shift;
+    return $method =~ /^(?:GET|POST|HEAD|PUT|DELETE)$/;
+}
+
 =head1 AUTHOR
 
-Copyright (c) 2004-2005 Jesse Vincent, <jesse at bestpractical.com>.
+Copyright (c) 2004-2006 Jesse Vincent, <jesse at bestpractical.com>.
 All rights reserved.
 
 Marcus Ramberg <drave at thefeed.no> contributed tests, cleanup, etc


Property changes on: packages/libhttp-server-simple-perl/branches/upstream/current/lib/HTTP/Server/Simple.pm
___________________________________________________________________
Name: svn:executable
   - 
   + *




More information about the Pkg-perl-cvs-commits mailing list