Import original source of Apache-Session-SQLite3 0.09
Xavier Guimard
6 years ago
0 | [Changes for 0.03 - 2005-02-02] | |
1 | ||
2 | * Fixed clobbering of $_ and $@ during ->store calls. | |
3 | * First version under svk management. |
0 | Changes | |
1 | inc/Module/Install.pm | |
2 | inc/Module/Install/Base.pm | |
3 | inc/Module/Install/Can.pm | |
4 | inc/Module/Install/Fetch.pm | |
5 | inc/Module/Install/Makefile.pm | |
6 | inc/Module/Install/Metadata.pm | |
7 | inc/Module/Install/Win32.pm | |
8 | inc/Module/Install/WriteAll.pm | |
9 | lib/Apache/Session/SQLite3.pm | |
10 | lib/Apache/Session/Store/SQLite3.pm | |
11 | Makefile.PL | |
12 | MANIFEST This list of files | |
13 | META.yml | |
14 | README | |
15 | SIGNATURE | |
16 | t/1-basic.t |
0 | name: Apache-Session-SQLite3 | |
1 | version: 0.03 | |
2 | abstract: Use DBD::SQLite 1.x for Apache::Session storage | |
3 | author: Autrijus Tang <autrijus@autrijus.org> | |
4 | license: perl | |
5 | distribution_type: module | |
6 | requires: | |
7 | DBD::SQLite: 1.00 | |
8 | Apache::Session: 0.15 | |
9 | no_index: | |
10 | directory: | |
11 | - inc | |
12 | generated_by: Module::Install version 0.36 |
0 | #!/usr/local/bin/perl | |
1 | ||
2 | use inc::Module::Install; | |
3 | ||
4 | name ('Apache-Session-SQLite3'); | |
5 | author ('Autrijus Tang <autrijus@autrijus.org>'); | |
6 | abstract ('Use DBD::SQLite 1.x for Apache::Session storage'); | |
7 | license ('perl'); | |
8 | version_from('lib/Apache/Session/SQLite3.pm'); | |
9 | requires (qw( | |
10 | DBD::SQLite 1.00 | |
11 | Apache::Session 0.15 | |
12 | )); | |
13 | WriteAll ( sign => 1 ); |
0 | This is the README file for Apache::Session::SQLite3, an Apache::Session | |
1 | subclass using DBD::SQLite 1.x. | |
2 | ||
3 | Please type "perldoc Apache::Session::SQLite3" after installation to see | |
4 | the module usage information. | |
5 | ||
6 | * Installation | |
7 | ||
8 | Apache::Session::SQLite3 uses the standard perl module install process: | |
9 | ||
10 | cpansign -v # optional; see SIGNATURE for details | |
11 | perl Makefile.PL | |
12 | make # or 'nmake' on Win32 | |
13 | make test | |
14 | make install | |
15 | ||
16 | * Copyright | |
17 | ||
18 | Copyright 2004, 2005 by Autrijus Tang <autrijus@autrijus.org>. | |
19 | ||
20 | All rights reserved. You can redistribute and/or modify | |
21 | this bundle under the same terms as Perl itself. | |
22 | ||
23 | See <http://www.perl.com/perl/misc/Artistic.html>. |
0 | This file contains message digests of all files listed in MANIFEST, | |
1 | signed via the Module::Signature module, version 0.44. | |
2 | ||
3 | To verify the content in this distribution, first make sure you have | |
4 | Module::Signature installed, then type: | |
5 | ||
6 | % cpansign -v | |
7 | ||
8 | It will check each file's integrity, as well as the signature's | |
9 | validity. If "==> Signature verified OK! <==" is not displayed, | |
10 | the distribution may already have been compromised, and you should | |
11 | not run its Makefile.PL or Build.PL. | |
12 | ||
13 | -----BEGIN PGP SIGNED MESSAGE----- | |
14 | Hash: SHA1 | |
15 | ||
16 | SHA1 7d06199eb13a9cb916722a3d7e96334c26a79185 Changes | |
17 | SHA1 b48bff4ee1d73db253c2eb73749a4e2daddfc944 MANIFEST | |
18 | SHA1 4faf77381c483cc19900be7db592bcb97a706c67 META.yml | |
19 | SHA1 1e28aad8580dd64a2ebd4e7f07515353a9c71880 Makefile.PL | |
20 | SHA1 de8d083e1b78301598ca1cf3ac1525ae1a926c02 README | |
21 | SHA1 06d883487127fa0026311904e7c4867e850c505c inc/Module/Install.pm | |
22 | SHA1 2771d5c5033e94c4789c66a0aad4e21c62985ce9 inc/Module/Install/Base.pm | |
23 | SHA1 b5e2d5fc07b92d042c97631d2b00f61f974fc164 inc/Module/Install/Can.pm | |
24 | SHA1 c3747aa4bd8faa530c974b78f729c67f15c6f928 inc/Module/Install/Fetch.pm | |
25 | SHA1 d8bc0d6e0a82d2b7533bdd3de467593094cc8b2c inc/Module/Install/Makefile.pm | |
26 | SHA1 6fca1d05c6b9a8f10865de5be4fefb9bfa7a52e9 inc/Module/Install/Metadata.pm | |
27 | SHA1 6b051a6d3ed824df40343a7ff09b66282e1783c3 inc/Module/Install/Win32.pm | |
28 | SHA1 77f82ce7c623e05304ac9aae05bcd1a5558fadbb inc/Module/Install/WriteAll.pm | |
29 | SHA1 0a55bae41ed08b4bdac7f6c35694308c7045256e lib/Apache/Session/SQLite3.pm | |
30 | SHA1 4cc80f00485821e7d665c3d09eb573fcc7c34361 lib/Apache/Session/Store/SQLite3.pm | |
31 | SHA1 6049b763901c2600adc57b55ded9e1d6ad3686d1 t/1-basic.t | |
32 | -----BEGIN PGP SIGNATURE----- | |
33 | Version: GnuPG v1.2.6 (FreeBSD) | |
34 | ||
35 | iD8DBQFCAKITtLPdNzw1AaARAuFZAKCfOu4NkW9Ny2eOTQyw/b2wKfxZLACdHRdK | |
36 | z+qDX5lvxbJITfjjE7K3Onw= | |
37 | =xCJK | |
38 | -----END PGP SIGNATURE----- |
0 | #line 1 "inc/Module/Install/Base.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Base.pm" | |
1 | package Module::Install::Base; | |
2 | ||
3 | #line 28 | |
4 | ||
5 | sub new { | |
6 | my ($class, %args) = @_; | |
7 | ||
8 | foreach my $method (qw(call load)) { | |
9 | *{"$class\::$method"} = sub { | |
10 | +shift->_top->$method(@_); | |
11 | } unless defined &{"$class\::$method"}; | |
12 | } | |
13 | ||
14 | bless(\%args, $class); | |
15 | } | |
16 | ||
17 | #line 46 | |
18 | ||
19 | sub AUTOLOAD { | |
20 | my $self = shift; | |
21 | goto &{$self->_top->autoload}; | |
22 | } | |
23 | ||
24 | #line 57 | |
25 | ||
26 | sub _top { $_[0]->{_top} } | |
27 | ||
28 | #line 68 | |
29 | ||
30 | sub admin { | |
31 | my $self = shift; | |
32 | $self->_top->{admin} or Module::Install::Base::FakeAdmin->new; | |
33 | } | |
34 | ||
35 | sub is_admin { | |
36 | my $self = shift; | |
37 | $self->admin->VERSION; | |
38 | } | |
39 | ||
40 | sub DESTROY {} | |
41 | ||
42 | package Module::Install::Base::FakeAdmin; | |
43 | ||
44 | my $Fake; | |
45 | sub new { $Fake ||= bless(\@_, $_[0]) } | |
46 | sub AUTOLOAD {} | |
47 | sub DESTROY {} | |
48 | ||
49 | 1; | |
50 | ||
51 | __END__ | |
52 | ||
53 | #line 112 |
0 | #line 1 "inc/Module/Install/Can.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Can.pm" | |
1 | package Module::Install::Can; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | $VERSION = '0.01'; | |
4 | ||
5 | use strict; | |
6 | use Config (); | |
7 | use File::Spec (); | |
8 | use ExtUtils::MakeMaker (); | |
9 | ||
10 | # check if we can run some command | |
11 | sub can_run { | |
12 | my ($self, $cmd) = @_; | |
13 | ||
14 | my $_cmd = $cmd; | |
15 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); | |
16 | ||
17 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { | |
18 | my $abs = File::Spec->catfile($dir, $_[1]); | |
19 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); | |
20 | } | |
21 | ||
22 | return; | |
23 | } | |
24 | ||
25 | sub can_cc { | |
26 | my $self = shift; | |
27 | my @chunks = split(/ /, $Config::Config{cc}) or return; | |
28 | ||
29 | # $Config{cc} may contain args; try to find out the program part | |
30 | while (@chunks) { | |
31 | return $self->can_run("@chunks") || (pop(@chunks), next); | |
32 | } | |
33 | ||
34 | return; | |
35 | } | |
36 | ||
37 | 1; |
0 | #line 1 "inc/Module/Install/Fetch.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Fetch.pm" | |
1 | package Module::Install::Fetch; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | ||
4 | $VERSION = '0.01'; | |
5 | ||
6 | sub get_file { | |
7 | my ($self, %args) = @_; | |
8 | my ($scheme, $host, $path, $file) = | |
9 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; | |
10 | ||
11 | if ($scheme eq 'http' and !eval { require LWP::Simple; 1 }) { | |
12 | $args{url} = $args{ftp_url} | |
13 | or (warn("LWP support unavailable!\n"), return); | |
14 | ($scheme, $host, $path, $file) = | |
15 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; | |
16 | } | |
17 | ||
18 | $|++; | |
19 | print "Fetching '$file' from $host... "; | |
20 | ||
21 | unless (eval { require Socket; Socket::inet_aton($host) }) { | |
22 | warn "'$host' resolve failed!\n"; | |
23 | return; | |
24 | } | |
25 | ||
26 | return unless $scheme eq 'ftp' or $scheme eq 'http'; | |
27 | ||
28 | require Cwd; | |
29 | my $dir = Cwd::getcwd(); | |
30 | chdir $args{local_dir} or return if exists $args{local_dir}; | |
31 | ||
32 | if (eval { require LWP::Simple; 1 }) { | |
33 | LWP::Simple::mirror($args{url}, $file); | |
34 | } | |
35 | elsif (eval { require Net::FTP; 1 }) { eval { | |
36 | # use Net::FTP to get past firewall | |
37 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); | |
38 | $ftp->login("anonymous", 'anonymous@example.com'); | |
39 | $ftp->cwd($path); | |
40 | $ftp->binary; | |
41 | $ftp->get($file) or (warn("$!\n"), return); | |
42 | $ftp->quit; | |
43 | } } | |
44 | elsif (my $ftp = $self->can_run('ftp')) { eval { | |
45 | # no Net::FTP, fallback to ftp.exe | |
46 | require FileHandle; | |
47 | my $fh = FileHandle->new; | |
48 | ||
49 | local $SIG{CHLD} = 'IGNORE'; | |
50 | unless ($fh->open("|$ftp -n")) { | |
51 | warn "Couldn't open ftp: $!\n"; | |
52 | chdir $dir; return; | |
53 | } | |
54 | ||
55 | my @dialog = split(/\n/, << "."); | |
56 | open $host | |
57 | user anonymous anonymous\@example.com | |
58 | cd $path | |
59 | binary | |
60 | get $file $file | |
61 | quit | |
62 | . | |
63 | foreach (@dialog) { $fh->print("$_\n") } | |
64 | $fh->close; | |
65 | } } | |
66 | else { | |
67 | warn "No working 'ftp' program available!\n"; | |
68 | chdir $dir; return; | |
69 | } | |
70 | ||
71 | unless (-f $file) { | |
72 | warn "Fetching failed: $@\n"; | |
73 | chdir $dir; return; | |
74 | } | |
75 | ||
76 | return if exists $args{size} and -s $file != $args{size}; | |
77 | system($args{run}) if exists $args{run}; | |
78 | unlink($file) if $args{remove}; | |
79 | ||
80 | print(((!exists $args{check_for} or -e $args{check_for}) | |
81 | ? "done!" : "failed! ($!)"), "\n"); | |
82 | chdir $dir; return !$?; | |
83 | } | |
84 | ||
85 | 1; |
0 | #line 1 "inc/Module/Install/Makefile.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Makefile.pm" | |
1 | package Module::Install::Makefile; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | ||
4 | $VERSION = '0.01'; | |
5 | ||
6 | use strict 'vars'; | |
7 | use vars '$VERSION'; | |
8 | ||
9 | use ExtUtils::MakeMaker (); | |
10 | ||
11 | sub Makefile { $_[0] } | |
12 | ||
13 | sub prompt { | |
14 | shift; | |
15 | goto &ExtUtils::MakeMaker::prompt; | |
16 | } | |
17 | ||
18 | sub makemaker_args { | |
19 | my $self = shift; | |
20 | my $args = ($self->{makemaker_args} ||= {}); | |
21 | %$args = ( %$args, @_ ) if @_; | |
22 | $args; | |
23 | } | |
24 | ||
25 | sub clean_files { | |
26 | my $self = shift; | |
27 | my $clean = $self->makemaker_args->{clean} ||= {}; | |
28 | %$clean = ( | |
29 | %$clean, | |
30 | FILES => join(" ", grep length, $clean->{FILES}, @_), | |
31 | ); | |
32 | } | |
33 | ||
34 | sub libs { | |
35 | my $self = shift; | |
36 | my $libs = ref $_[0] ? shift : [shift]; | |
37 | $self->makemaker_args( LIBS => $libs ); | |
38 | } | |
39 | ||
40 | sub inc { | |
41 | my $self = shift; | |
42 | $self->makemaker_args( INC => shift ); | |
43 | } | |
44 | ||
45 | sub write { | |
46 | my $self = shift; | |
47 | die "&Makefile->write() takes no arguments\n" if @_; | |
48 | ||
49 | my $args = $self->makemaker_args; | |
50 | ||
51 | $args->{DISTNAME} = $self->name; | |
52 | $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); | |
53 | $args->{VERSION} = $self->version || $self->determine_VERSION($args); | |
54 | $args->{NAME} =~ s/-/::/g; | |
55 | ||
56 | if ($] >= 5.005) { | |
57 | $args->{ABSTRACT} = $self->abstract; | |
58 | $args->{AUTHOR} = $self->author; | |
59 | } | |
60 | if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { | |
61 | $args->{NO_META} = 1; | |
62 | } | |
63 | if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 ) { | |
64 | $args->{SIGN} = 1 if $self->sign; | |
65 | } | |
66 | delete $args->{SIGN} unless $self->is_admin; | |
67 | ||
68 | # merge both kinds of requires into prereq_pm | |
69 | my $prereq = ($args->{PREREQ_PM} ||= {}); | |
70 | %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, | |
71 | ($self->build_requires, $self->requires) ); | |
72 | ||
73 | # merge both kinds of requires into prereq_pm | |
74 | my $dir = ($args->{DIR} ||= []); | |
75 | if ($self->bundles) { | |
76 | push @$dir, map "$_->[1]", @{$self->bundles}; | |
77 | delete $prereq->{$_->[0]} for @{$self->bundles}; | |
78 | } | |
79 | ||
80 | if (my $perl_version = $self->perl_version) { | |
81 | eval "use $perl_version; 1" | |
82 | or die "ERROR: perl: Version $] is installed, ". | |
83 | "but we need version >= $perl_version"; | |
84 | } | |
85 | ||
86 | my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args; | |
87 | ||
88 | if ($self->admin->preop) { | |
89 | $args{dist} = $self->admin->preop; | |
90 | } | |
91 | ||
92 | ExtUtils::MakeMaker::WriteMakefile(%args); | |
93 | ||
94 | $self->fix_up_makefile(); | |
95 | } | |
96 | ||
97 | sub fix_up_makefile { | |
98 | my $self = shift; | |
99 | my $top_class = ref($self->_top) || ''; | |
100 | my $top_version = $self->_top->VERSION || ''; | |
101 | ||
102 | my $preamble = $self->preamble | |
103 | ? "# Preamble by $top_class $top_version\n" . $self->preamble | |
104 | : ''; | |
105 | my $postamble = "# Postamble by $top_class $top_version\n" . | |
106 | ($self->postamble || ''); | |
107 | ||
108 | open MAKEFILE, '< Makefile' or die $!; | |
109 | my $makefile = do { local $/; <MAKEFILE> }; | |
110 | close MAKEFILE; | |
111 | ||
112 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; | |
113 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; | |
114 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; | |
115 | ||
116 | $makefile =~ s/^(FULLPERL = .*)/$1 -Iinc/m; | |
117 | $makefile =~ s/^(PERL = .*)/$1 -Iinc/m; | |
118 | ||
119 | open MAKEFILE, '> Makefile' or die $!; | |
120 | print MAKEFILE "$preamble$makefile$postamble"; | |
121 | close MAKEFILE; | |
122 | } | |
123 | ||
124 | sub preamble { | |
125 | my ($self, $text) = @_; | |
126 | $self->{preamble} = $text . $self->{preamble} if defined $text; | |
127 | $self->{preamble}; | |
128 | } | |
129 | ||
130 | sub postamble { | |
131 | my ($self, $text) = @_; | |
132 | ||
133 | $self->{postamble} ||= $self->admin->postamble; | |
134 | $self->{postamble} .= $text if defined $text; | |
135 | $self->{postamble} | |
136 | } | |
137 | ||
138 | 1; | |
139 | ||
140 | __END__ | |
141 | ||
142 | #line 273 |
0 | #line 1 "inc/Module/Install/Metadata.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Metadata.pm" | |
1 | package Module::Install::Metadata; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | ||
4 | $VERSION = '0.04'; | |
5 | ||
6 | use strict 'vars'; | |
7 | use vars qw($VERSION); | |
8 | ||
9 | sub Meta { shift } | |
10 | ||
11 | my @scalar_keys = qw( | |
12 | name module_name version abstract author license | |
13 | distribution_type sign perl_version | |
14 | ); | |
15 | my @tuple_keys = qw(build_requires requires recommends bundles); | |
16 | ||
17 | foreach my $key (@scalar_keys) { | |
18 | *$key = sub { | |
19 | my $self = shift; | |
20 | return $self->{'values'}{$key} unless @_; | |
21 | $self->{'values'}{$key} = shift; | |
22 | return $self; | |
23 | }; | |
24 | } | |
25 | ||
26 | foreach my $key (@tuple_keys) { | |
27 | *$key = sub { | |
28 | my $self = shift; | |
29 | return $self->{'values'}{$key} unless @_; | |
30 | my @rv; | |
31 | while (@_) { | |
32 | my $module = shift or last; | |
33 | my $version = shift || 0; | |
34 | if ($module eq 'perl') { | |
35 | $version =~ s{^(\d+)\.(\d+)\.(\d+)} | |
36 | {$1 + $2/1_000 + $3/1_000_000}e; | |
37 | $self->perl_version($version); | |
38 | next; | |
39 | } | |
40 | my $rv = [$module, $version]; | |
41 | push @{$self->{'values'}{$key}}, $rv; | |
42 | push @rv, $rv; | |
43 | } | |
44 | return @rv; | |
45 | }; | |
46 | } | |
47 | ||
48 | sub features { | |
49 | my $self = shift; | |
50 | while (my ($name, $mods) = splice(@_, 0, 2)) { | |
51 | my $count = 0; | |
52 | push @{$self->{'values'}{'features'}}, ($name => [ | |
53 | map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods | |
54 | ] ); | |
55 | } | |
56 | return @{$self->{'values'}{'features'}}; | |
57 | } | |
58 | ||
59 | sub no_index { | |
60 | my $self = shift; | |
61 | my $type = shift; | |
62 | push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type; | |
63 | return $self->{'values'}{'no_index'}; | |
64 | } | |
65 | ||
66 | sub _dump { | |
67 | my $self = shift; | |
68 | my $package = ref($self->_top); | |
69 | my $version = $self->_top->VERSION; | |
70 | my %values = %{$self->{'values'}}; | |
71 | ||
72 | delete $values{sign}; | |
73 | if (my $perl_version = delete $values{perl_version}) { | |
74 | # Always canonical to three-dot version | |
75 | $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e | |
76 | if $perl_version >= 5.006; | |
77 | $values{requires} = [ | |
78 | [perl => $perl_version], | |
79 | @{$values{requires}||[]}, | |
80 | ]; | |
81 | } | |
82 | ||
83 | warn "No license specified, setting license = 'unknown'\n" | |
84 | unless $values{license}; | |
85 | ||
86 | $values{license} ||= 'unknown'; | |
87 | $values{distribution_type} ||= 'module'; | |
88 | $values{name} ||= do { | |
89 | my $name = $values{module_name}; | |
90 | $name =~ s/::/-/g; | |
91 | $name; | |
92 | } if $values{module_name}; | |
93 | ||
94 | if ($values{name} =~ /::/) { | |
95 | my $name = $values{name}; | |
96 | $name =~ s/::/-/g; | |
97 | die "Error in name(): '$values{name}' should be '$name'!\n"; | |
98 | } | |
99 | ||
100 | my $dump = ''; | |
101 | foreach my $key (@scalar_keys) { | |
102 | $dump .= "$key: $values{$key}\n" if exists $values{$key}; | |
103 | } | |
104 | foreach my $key (@tuple_keys) { | |
105 | next unless exists $values{$key}; | |
106 | $dump .= "$key:\n"; | |
107 | foreach (@{$values{$key}}) { | |
108 | $dump .= " $_->[0]: $_->[1]\n"; | |
109 | } | |
110 | } | |
111 | ||
112 | if (my $no_index = $values{no_index}) { | |
113 | push @{$no_index->{'directory'}}, 'inc'; | |
114 | require YAML; | |
115 | local $YAML::UseHeader = 0; | |
116 | $dump .= YAML::Dump({ no_index => $no_index}); | |
117 | } | |
118 | else { | |
119 | $dump .= << "META"; | |
120 | no_index: | |
121 | directory: | |
122 | - inc | |
123 | META | |
124 | } | |
125 | ||
126 | $dump .= "generated_by: $package version $version\n"; | |
127 | return $dump; | |
128 | } | |
129 | ||
130 | sub read { | |
131 | my $self = shift; | |
132 | $self->include_deps( 'YAML', 0 ); | |
133 | require YAML; | |
134 | my $data = YAML::LoadFile( 'META.yml' ); | |
135 | # Call methods explicitly in case user has already set some values. | |
136 | while ( my ($key, $value) = each %$data ) { | |
137 | next unless $self->can( $key ); | |
138 | if (ref $value eq 'HASH') { | |
139 | while (my ($module, $version) = each %$value) { | |
140 | $self->$key( $module => $version ); | |
141 | } | |
142 | } | |
143 | else { | |
144 | $self->$key( $value ); | |
145 | } | |
146 | } | |
147 | return $self; | |
148 | } | |
149 | ||
150 | sub write { | |
151 | my $self = shift; | |
152 | return $self unless $self->is_admin; | |
153 | ||
154 | META_NOT_OURS: { | |
155 | local *FH; | |
156 | if (open FH, "META.yml") { | |
157 | while (<FH>) { | |
158 | last META_NOT_OURS if /^generated_by: Module::Install\b/; | |
159 | } | |
160 | return $self if -s FH; | |
161 | } | |
162 | } | |
163 | ||
164 | warn "Writing META.yml\n"; | |
165 | open META, "> META.yml" or warn "Cannot write to META.yml: $!"; | |
166 | print META $self->_dump; | |
167 | close META; | |
168 | return $self; | |
169 | } | |
170 | ||
171 | sub version_from { | |
172 | my ($self, $version_from) = @_; | |
173 | require ExtUtils::MM_Unix; | |
174 | $self->version(ExtUtils::MM_Unix->parse_version($version_from)); | |
175 | } | |
176 | ||
177 | sub abstract_from { | |
178 | my ($self, $abstract_from) = @_; | |
179 | require ExtUtils::MM_Unix; | |
180 | $self->abstract( | |
181 | bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix') | |
182 | ->parse_abstract($abstract_from) | |
183 | ); | |
184 | } | |
185 | ||
186 | 1; |
0 | #line 1 "inc/Module/Install/Win32.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/Win32.pm" | |
1 | package Module::Install::Win32; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | ||
4 | $VERSION = '0.02'; | |
5 | ||
6 | use strict; | |
7 | ||
8 | # determine if the user needs nmake, and download it if needed | |
9 | sub check_nmake { | |
10 | my $self = shift; | |
11 | $self->load('can_run'); | |
12 | $self->load('get_file'); | |
13 | ||
14 | require Config; | |
15 | return unless ( | |
16 | $Config::Config{make} and | |
17 | $Config::Config{make} =~ /^nmake\b/i and | |
18 | $^O eq 'MSWin32' and | |
19 | !$self->can_run('nmake') | |
20 | ); | |
21 | ||
22 | print "The required 'nmake' executable not found, fetching it...\n"; | |
23 | ||
24 | require File::Basename; | |
25 | my $rv = $self->get_file( | |
26 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', | |
27 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', | |
28 | local_dir => File::Basename::dirname($^X), | |
29 | size => 51928, | |
30 | run => 'Nmake15.exe /o > nul', | |
31 | check_for => 'Nmake.exe', | |
32 | remove => 1, | |
33 | ); | |
34 | ||
35 | if (!$rv) { | |
36 | die << '.'; | |
37 | ||
38 | ------------------------------------------------------------------------------- | |
39 | ||
40 | Since you are using Microsoft Windows, you will need the 'nmake' utility | |
41 | before installation. It's available at: | |
42 | ||
43 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe | |
44 | or | |
45 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe | |
46 | ||
47 | Please download the file manually, save it to a directory in %PATH% (e.g. | |
48 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to | |
49 | that directory, and run "Nmake15.exe" from there; that will create the | |
50 | 'nmake.exe' file needed by this module. | |
51 | ||
52 | You may then resume the installation process described in README. | |
53 | ||
54 | ------------------------------------------------------------------------------- | |
55 | . | |
56 | } | |
57 | } | |
58 | ||
59 | 1; | |
60 | ||
61 | __END__ | |
62 |
0 | #line 1 "inc/Module/Install/WriteAll.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install/WriteAll.pm" | |
1 | package Module::Install::WriteAll; | |
2 | use Module::Install::Base; @ISA = qw(Module::Install::Base); | |
3 | ||
4 | sub WriteAll { | |
5 | my $self = shift; | |
6 | my %args = ( | |
7 | meta => 1, | |
8 | sign => 0, | |
9 | inline => 0, | |
10 | check_nmake => 1, | |
11 | @_ | |
12 | ); | |
13 | ||
14 | $self->sign(1) if $args{sign}; | |
15 | $self->Meta->write if $args{meta}; | |
16 | $self->admin->WriteAll(%args) if $self->is_admin; | |
17 | ||
18 | if ($0 =~ /Build.PL$/i) { | |
19 | $self->Build->write; | |
20 | } | |
21 | else { | |
22 | $self->check_nmake if $args{check_nmake}; | |
23 | $self->makemaker_args( PL_FILES => {} ) | |
24 | unless $self->makemaker_args->{'PL_FILES'}; | |
25 | ||
26 | if ($args{inline}) { | |
27 | $self->Inline->write; | |
28 | } | |
29 | else { | |
30 | $self->Makefile->write; | |
31 | } | |
32 | } | |
33 | } | |
34 | ||
35 | 1; |
0 | #line 1 "inc/Module/Install.pm - /usr/local/lib/perl5/site_perl/5.8.5/Module/Install.pm" | |
1 | package Module::Install; | |
2 | $VERSION = '0.36'; | |
3 | ||
4 | die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'}; | |
5 | Please invoke ${\__PACKAGE__} with: | |
6 | ||
7 | use inc::${\__PACKAGE__}; | |
8 | ||
9 | not: | |
10 | ||
11 | use ${\__PACKAGE__}; | |
12 | ||
13 | . | |
14 | ||
15 | use strict 'vars'; | |
16 | use Cwd (); | |
17 | use File::Find (); | |
18 | use File::Path (); | |
19 | ||
20 | @inc::Module::Install::ISA = 'Module::Install'; | |
21 | *inc::Module::Install::VERSION = *VERSION; | |
22 | ||
23 | #line 129 | |
24 | ||
25 | sub import { | |
26 | my $class = shift; | |
27 | my $self = $class->new(@_); | |
28 | ||
29 | if (not -f $self->{file}) { | |
30 | require "$self->{path}/$self->{dispatch}.pm"; | |
31 | File::Path::mkpath("$self->{prefix}/$self->{author}"); | |
32 | $self->{admin} = | |
33 | "$self->{name}::$self->{dispatch}"->new(_top => $self); | |
34 | $self->{admin}->init; | |
35 | @_ = ($class, _self => $self); | |
36 | goto &{"$self->{name}::import"}; | |
37 | } | |
38 | ||
39 | *{caller(0) . "::AUTOLOAD"} = $self->autoload; | |
40 | ||
41 | # Unregister loader and worker packages so subdirs can use them again | |
42 | delete $INC{"$self->{file}"}; | |
43 | delete $INC{"$self->{path}.pm"}; | |
44 | } | |
45 | ||
46 | #line 156 | |
47 | ||
48 | sub autoload { | |
49 | my $self = shift; | |
50 | my $caller = caller; | |
51 | ||
52 | my $cwd = Cwd::cwd(); | |
53 | my $sym = "$caller\::AUTOLOAD"; | |
54 | ||
55 | $sym->{$cwd} = sub { | |
56 | my $pwd = Cwd::cwd(); | |
57 | if (my $code = $sym->{$pwd}) { | |
58 | goto &$code unless $cwd eq $pwd; # delegate back to parent dirs | |
59 | } | |
60 | $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller"; | |
61 | unshift @_, ($self, $1); | |
62 | goto &{$self->can('call')} unless uc($1) eq $1; | |
63 | }; | |
64 | } | |
65 | ||
66 | #line 181 | |
67 | ||
68 | sub new { | |
69 | my ($class, %args) = @_; | |
70 | ||
71 | return $args{_self} if $args{_self}; | |
72 | ||
73 | $args{dispatch} ||= 'Admin'; | |
74 | $args{prefix} ||= 'inc'; | |
75 | $args{author} ||= '.author'; | |
76 | $args{bundle} ||= 'inc/BUNDLES'; | |
77 | ||
78 | $class =~ s/^\Q$args{prefix}\E:://; | |
79 | $args{name} ||= $class; | |
80 | $args{version} ||= $class->VERSION; | |
81 | ||
82 | unless ($args{path}) { | |
83 | $args{path} = $args{name}; | |
84 | $args{path} =~ s!::!/!g; | |
85 | } | |
86 | $args{file} ||= "$args{prefix}/$args{path}.pm"; | |
87 | ||
88 | bless(\%args, $class); | |
89 | } | |
90 | ||
91 | #line 210 | |
92 | ||
93 | sub call { | |
94 | my $self = shift; | |
95 | my $method = shift; | |
96 | my $obj = $self->load($method) or return; | |
97 | ||
98 | unshift @_, $obj; | |
99 | goto &{$obj->can($method)}; | |
100 | } | |
101 | ||
102 | #line 225 | |
103 | ||
104 | sub load { | |
105 | my ($self, $method) = @_; | |
106 | ||
107 | $self->load_extensions( | |
108 | "$self->{prefix}/$self->{path}", $self | |
109 | ) unless $self->{extensions}; | |
110 | ||
111 | foreach my $obj (@{$self->{extensions}}) { | |
112 | return $obj if $obj->can($method); | |
113 | } | |
114 | ||
115 | my $admin = $self->{admin} or die << "END"; | |
116 | The '$method' method does not exist in the '$self->{prefix}' path! | |
117 | Please remove the '$self->{prefix}' directory and run $0 again to load it. | |
118 | END | |
119 | ||
120 | my $obj = $admin->load($method, 1); | |
121 | push @{$self->{extensions}}, $obj; | |
122 | ||
123 | $obj; | |
124 | } | |
125 | ||
126 | #line 255 | |
127 | ||
128 | sub load_extensions { | |
129 | my ($self, $path, $top_obj) = @_; | |
130 | ||
131 | unshift @INC, $self->{prefix} | |
132 | unless grep { $_ eq $self->{prefix} } @INC; | |
133 | ||
134 | local @INC = ($path, @INC); | |
135 | foreach my $rv ($self->find_extensions($path)) { | |
136 | my ($file, $pkg) = @{$rv}; | |
137 | next if $self->{pathnames}{$pkg}; | |
138 | ||
139 | eval { require $file; 1 } or (warn($@), next); | |
140 | $self->{pathnames}{$pkg} = delete $INC{$file}; | |
141 | push @{$self->{extensions}}, $pkg->new( _top => $top_obj ); | |
142 | } | |
143 | } | |
144 | ||
145 | #line 279 | |
146 | ||
147 | sub find_extensions { | |
148 | my ($self, $path) = @_; | |
149 | my @found; | |
150 | ||
151 | File::Find::find(sub { | |
152 | my $file = $File::Find::name; | |
153 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; | |
154 | return if $1 eq $self->{dispatch}; | |
155 | ||
156 | $file = "$self->{path}/$1.pm"; | |
157 | my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g; | |
158 | push @found, [$file, $pkg]; | |
159 | }, $path) if -d $path; | |
160 | ||
161 | @found; | |
162 | } | |
163 | ||
164 | 1; | |
165 | ||
166 | __END__ | |
167 | ||
168 | #line 617 |
0 | package Apache::Session::SQLite3; | |
1 | $Apache::Session::SQLite3::VERSION = '0.03'; | |
2 | ||
3 | use strict; | |
4 | use base 'Apache::Session'; | |
5 | ||
6 | use DBD::SQLite 1.00; | |
7 | use Apache::Session; | |
8 | use Apache::Session::Lock::Null; | |
9 | use Apache::Session::Store::SQLite3; | |
10 | use Apache::Session::Generate::MD5; | |
11 | use Apache::Session::Serialize::Storable; | |
12 | ||
13 | sub populate { | |
14 | my $self = shift; | |
15 | ||
16 | $self->{object_store} = Apache::Session::Store::SQLite3->new($self); | |
17 | $self->{lock_manager} = Apache::Session::Lock::Null->new($self); | |
18 | $self->{generate} = \&Apache::Session::Generate::MD5::generate; | |
19 | $self->{validate} = \&Apache::Session::Generate::MD5::validate; | |
20 | $self->{serialize} = \&Apache::Session::Serialize::Storable::serialize; | |
21 | $self->{unserialize} = \&Apache::Session::Serialize::Storable::unserialize; | |
22 | ||
23 | return $self; | |
24 | } | |
25 | ||
26 | 1; | |
27 | ||
28 | =head1 NAME | |
29 | ||
30 | Apache::Session::SQLite3 - Use DBD::SQLite 1.x for Apache::Session storage | |
31 | ||
32 | =head1 VERSION | |
33 | ||
34 | This document describes version 0.03 of Apache::Session::SQLite3, released | |
35 | February 2, 2005. | |
36 | ||
37 | =head1 SYNOPSIS | |
38 | ||
39 | use Apache::Session::SQLite3; | |
40 | ||
41 | tie %hash, 'Apache::Session::SQLite3', $id, { | |
42 | DataSource => 'dbi:SQLite:dbname=/tmp/session.db' | |
43 | }; | |
44 | ||
45 | # to purge all sessions older than 30 days, do this: | |
46 | tied(%hash)->{object_store}{dbh}->do(qq[ | |
47 | DELETE FROM Sessions WHERE ? > LastUpdated | |
48 | ], {}, time - (30 * 86400)); | |
49 | ||
50 | =head1 DESCRIPTION | |
51 | ||
52 | This module is an implementation of Apache::Session. It uses the DBD::SQLite | |
53 | backing store. It requires DBD::SQLite version 1.00 or above, due to its use | |
54 | of SQLite3 API for BLOB support. Also, an extra C<LastUpdated> field is | |
55 | populated with the current C<time()>. | |
56 | ||
57 | There is no need to create the data source file beforehand; this module creates | |
58 | the C<session> table automatically. | |
59 | ||
60 | =head1 AUTHOR | |
61 | ||
62 | Autrijus Tang E<lt>autrijus@autrijus.orgE<gt> | |
63 | ||
64 | =head1 COPYRIGHT | |
65 | ||
66 | Copyright 2004, 2005 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>. | |
67 | ||
68 | This program is free software; you can redistribute it and/or modify it | |
69 | under the same terms as Perl itself. | |
70 | ||
71 | See L<http://www.perl.com/perl/misc/Artistic.html> | |
72 | ||
73 | =head1 SEE ALSO | |
74 | ||
75 | L<Apache::Session>, L<Apache::Session::SQLite>, L<DBD::SQLite> | |
76 | ||
77 | =cut |
0 | package Apache::Session::Store::SQLite3; | |
1 | $Apache::Session::Store::SQLite3::VERSION = '0.03'; | |
2 | ||
3 | use strict; | |
4 | use base 'Apache::Session::Store::DBI'; | |
5 | use vars qw($TableName $DataSource $UserName $Password); | |
6 | ||
7 | use DBI qw(:sql_types); | |
8 | use Apache::Session::Store::DBI; | |
9 | ||
10 | sub connection { | |
11 | my $self = shift; | |
12 | my $session = shift; | |
13 | ||
14 | $self->_connection($session) unless defined $self->{dbh}; | |
15 | ||
16 | my $tables = $self->{dbh}->selectall_arrayref(qq[ | |
17 | SELECT name | |
18 | FROM sqlite_master | |
19 | WHERE type = 'table' | |
20 | AND name = ? | |
21 | ], {}, $self->{table_name}); | |
22 | ||
23 | $self->{dbh}->do(qq[ | |
24 | CREATE TABLE $self->{table_name} ( | |
25 | id char(32) NOT NULL, | |
26 | a_session LONGBLOB, | |
27 | LastUpdated TIMESTAMP, | |
28 | PRIMARY KEY (id) | |
29 | ); | |
30 | ]) if !@$tables; | |
31 | } | |
32 | ||
33 | sub _connection { | |
34 | my $self = shift; | |
35 | my $session = shift; | |
36 | ||
37 | $self->{'table_name'} = $session->{args}->{TableName} | |
38 | || $TableName | |
39 | || $Apache::Session::Store::DBI::TableName; | |
40 | ||
41 | if (exists $session->{args}->{Handle}) { | |
42 | $self->{dbh} = $session->{args}->{Handle}; | |
43 | return; | |
44 | } | |
45 | ||
46 | my $datasource = $session->{args}->{DataSource} || $DataSource; | |
47 | my $username = $session->{args}->{UserName} || $UserName; | |
48 | my $password = $session->{args}->{Password} || $Password; | |
49 | ||
50 | $self->{dbh} = DBI->connect( | |
51 | $datasource, | |
52 | $username, | |
53 | $password, | |
54 | { RaiseError => 1, AutoCommit => 1 } | |
55 | ) or die $DBI::errstr; | |
56 | ||
57 | $self->{disconnect} = 1; | |
58 | } | |
59 | ||
60 | sub insert { | |
61 | my $self = shift; | |
62 | my $session = shift; | |
63 | ||
64 | $self->connection($session); | |
65 | ||
66 | local $self->{dbh}->{RaiseError} = 1; | |
67 | ||
68 | if (!defined $self->{insert_sth}) { | |
69 | $self->{insert_sth} = $self->{dbh}->prepare_cached(qq[ | |
70 | INSERT INTO $self->{'table_name'} (id, a_session, LastUpdated) | |
71 | VALUES (?, ?, ?) | |
72 | ]); | |
73 | } | |
74 | ||
75 | $self->{insert_sth}->bind_param(1, $session->{data}->{_session_id}, SQL_CHAR); | |
76 | $self->{insert_sth}->bind_param(2, $session->{serialized}, SQL_BLOB); | |
77 | $self->{insert_sth}->bind_param(3, time, SQL_INTEGER); | |
78 | ||
79 | $self->{insert_sth}->execute; | |
80 | $self->{insert_sth}->finish; | |
81 | } | |
82 | ||
83 | sub update { | |
84 | my $self = shift; | |
85 | my $session = shift; | |
86 | ||
87 | $self->connection($session); | |
88 | ||
89 | local $self->{dbh}->{RaiseError} = 1; | |
90 | ||
91 | if (!defined $self->{update_sth}) { | |
92 | $self->{update_sth} = $self->{dbh}->prepare_cached(qq[ | |
93 | UPDATE $self->{'table_name'} | |
94 | SET a_session = ?, LastUpdated = ? | |
95 | WHERE id = ? | |
96 | ]); | |
97 | } | |
98 | ||
99 | $self->{update_sth}->bind_param(1, $session->{serialized}, SQL_BLOB); | |
100 | $self->{update_sth}->bind_param(2, time, SQL_INTEGER); | |
101 | $self->{update_sth}->bind_param(3, $session->{data}->{_session_id}, SQL_CHAR); | |
102 | ||
103 | foreach my $count (1..600) { | |
104 | local $@; | |
105 | eval { $self->{update_sth}->execute; 1 } and last; | |
106 | sleep 1; | |
107 | } | |
108 | $self->{update_sth}->finish; | |
109 | } | |
110 | ||
111 | 1; |
0 | use strict; | |
1 | use Test::More tests => 4; | |
2 | ||
3 | use_ok('Apache::Session::SQLite3'); | |
4 | ||
5 | use DBI; | |
6 | use File::Temp qw(tempdir tempfile); | |
7 | ||
8 | my $dir = tempdir( CLEANUP => 1 ); | |
9 | my($fh, $filename) = tempfile( DIR => $dir ); | |
10 | close($fh); | |
11 | ||
12 | my $dbh = DBI->connect("dbi:SQLite:dbname=$filename","","") or die($!); | |
13 | ||
14 | tie my %hash, 'Apache::Session::SQLite3', undef, { | |
15 | DataSource => "dbi:SQLite:dbname=$filename", | |
16 | } or die($!); | |
17 | ||
18 | $hash{foo} = 'bar'; | |
19 | $hash{hash} = { foo => 'bar' }; | |
20 | ||
21 | my $sid = $hash{_session_id}; | |
22 | ||
23 | untie(%hash); | |
24 | ||
25 | tie %hash, 'Apache::Session::SQLite3', $sid, { | |
26 | DataSource => "dbi:SQLite:dbname=$filename", | |
27 | } or die($!); | |
28 | ||
29 | is($hash{foo}, 'bar', 'simple fetch works'); | |
30 | isa_ok($hash{hash}, 'HASH', 'stored reference'); | |
31 | is($hash{hash}{foo}, 'bar', 'multilevel fetch works'); | |
32 | ||
33 | 1; |