Net-Jifty-0.14/000755 000765 000024 00000000000 11510453206 013674 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/Changes000644 000765 000024 00000004173 11510453161 015174 0ustar00sartakstaff000000 000000 Revision history for Net-Jifty 0.14 3 Jan 2011 Bump to Encode 2.41 to fix a test issue with encoded periods (Sartak) 0.12 27 May 2009 Fix use of meta-attribute removed from triggers (Sartak) 0.11 19 Feb 2009 Depend on Any::Moose instead of Moose 0.10 Releng fixes Use a predicate for has_config_file 0.09 Hash::Merge and Path::Class are now depended-upon only if you want cascading directory config 0.08 Mon Nov 17 18:39:11 UTC-4 2008 added form_form_data_args method to support file uploads (ruz) reworked documentation (ruz) 0.07 Fri Aug 1 09:58:10 2008 Cache each action and model spec, add methods to retrieve them Better support for multiple values for a single key Make DateTime an optional dependency 0.06 Mon Mar 17 13:15:09 2008 Add directory filters for use by applications and subclasses Basically, each directory in your path can have a .jifty file with config in it. Each file is Hash::Merge'd. This lets your app have whatever context you want, based on where you are. appname is no longer required Add validate_action_args method and have ->act, ->create, etc use it if the strict_arguments attribute is true idea and proof of concept by John SJ Anderson 0.05 Mon Dec 21 01:56:40 2007 Removed canonicalize_action and canonicalize_model Allow search arguments to be arrayrefs, to facilitate using hashes for them. e.g: 'id => [1, 5]' is equivalent to 'id => 1, id => 5' 0.04 Mon Dec 7 15:28:23 2007 Work around an HTTP::Cookies bug with 'localhost' Add support for /=/search/ Fixes to create and act 0.03 Wed Nov 28 17:03:17 2007 Fix support for DELETE/PUT (patch by HANENKAMP) Workaround for a Jifty redirect bug (patch by HANENKAMP) Internals cleanups 0.02 Wed Nov 21 16:45:38 2007 Support for config files Some date/time and email methods 0.01 Tue Nov 20 22:25:37 2007 First version, released on an unsuspecting world. Net-Jifty-0.14/inc/000755 000765 000024 00000000000 11510453206 014445 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/lib/000755 000765 000024 00000000000 11510453206 014442 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/Makefile.PL000644 000765 000024 00000001326 11510451310 015642 0ustar00sartakstaff000000 000000 use inc::Module::Install; name 'Net-Jifty'; all_from 'lib/Net/Jifty.pm'; requires 'Any::Moose' => '0.04'; requires 'LWP::UserAgent'; requires 'YAML'; requires 'URI'; requires 'Encode' => '2.41'; build_requires 'Test::More'; build_requires 'Test::MockObject'; feature 'Date loading' => -default => 0, 'DateTime' => 0; feature 'Cascading directory config' => -default => 0, 'Hash::Merge' => 0, 'Path::Class' => 0, 'Cwd' => 0; feature 'Email address comparison' => -default => 0, 'Email::Address' => 0; feature 'Hiding password entry' => -default => 0, 'Term::ReadKey' => 0; auto_install; WriteAll; Net-Jifty-0.14/MANIFEST000644 000765 000024 00000001017 11510453172 015026 0ustar00sartakstaff000000 000000 Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Net/Jifty.pm Makefile.PL MANIFEST This list of files META.yml SIGNATURE t/000-load.t t/001-login.t t/002-method.t t/003-crud.t t/004-search.t t/005-validate.t t/006-uploads.t t/lib/Net/Jifty/Test.pm Net-Jifty-0.14/META.yml000644 000765 000024 00000001327 11510453171 015151 0ustar00sartakstaff000000 000000 --- abstract: 'interface to online Jifty applications' author: - 'Shawn M Moore, C<< >>' build_requires: ExtUtils::MakeMaker: 6.42 Test::MockObject: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-Jifty no_index: directory: - inc - t requires: Any::Moose: 0.04 Cwd: 0 DateTime: 0 Email::Address: 0 Encode: 2.41 Hash::Merge: 0 LWP::UserAgent: 0 Path::Class: 0 Term::ReadKey: 0 URI: 0 YAML: 0 resources: license: http://dev.perl.org/licenses/ version: 0.14 Net-Jifty-0.14/SIGNATURE000644 000765 000024 00000004431 11510453200 015154 0ustar00sartakstaff000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.66. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 e370176e540671a6705612345d56113204031386 Changes SHA1 13367ce99770ff913e30296bf48e76964342dc87 MANIFEST SHA1 b844ecdce91d3d639c62dda2fec0f848e5100576 META.yml SHA1 9fd2256a355074bc89fc6abaab99d03e771e236c Makefile.PL SHA1 20c73697e1713638140c719d8eaa19a275ed43a5 inc/Module/AutoInstall.pm SHA1 7305dbe2904416e28decb05396988a5d51d578be inc/Module/Install.pm SHA1 ca13d9875e1249f6e84f7070be8152c34837955e inc/Module/Install/AutoInstall.pm SHA1 129960509127732258570c122042bc48615222e1 inc/Module/Install/Base.pm SHA1 cf3356ed9a5bd2f732527ef9e7bc5ef4458c8a93 inc/Module/Install/Can.pm SHA1 bf0a3e1977effc2832d7a813a76dce3f31b437b6 inc/Module/Install/Fetch.pm SHA1 b501b0df59a5cd235cca473889f82c3d3429f39e inc/Module/Install/Include.pm SHA1 b721c93ca5bc9a6aa863b49af15f1b1de6125935 inc/Module/Install/Makefile.pm SHA1 026cc0551a0ad399d195e395b46bdf842e115192 inc/Module/Install/Metadata.pm SHA1 5457015ea5a50e93465bf2dafa29feebd547f85b inc/Module/Install/Win32.pm SHA1 051e7fa8063908befa3440508d0584a2497b97db inc/Module/Install/WriteAll.pm SHA1 7a52811c9ea15bff3d2233a40214192dc9e4b373 lib/Net/Jifty.pm SHA1 d82ea49d1cb9b8cda33214dcd82851835a44efea t/000-load.t SHA1 72071d94a22f5797e5f6bbf135d84d03a8eaa84b t/001-login.t SHA1 e8dd1626d4ac55f9917aecfc6177d3df8040c101 t/002-method.t SHA1 987d9fb3decf47c1992a29c31c96222bfb1cc380 t/003-crud.t SHA1 0ed91f86dac1087841dfb7aa187f3335d19122cf t/004-search.t SHA1 ea5281ab3301ab40a5f16bf98954ceba2775507f t/005-validate.t SHA1 38b58b5e7a6208596fe214512a67fc19b8ffb2bd t/006-uploads.t SHA1 5772ce7104d2f41dd4bd6cbff24efa6fb4a17c61 t/lib/Net/Jifty/Test.pm -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (Darwin) iEYEARECAAYFAk0iVn0ACgkQsxfQtHhyRPpm5gCeOkJUpFLBhOcjKSJRRWdwIuL1 c2wAn1zSjM+tO3bTvDQI3c2QQsKkUL5u =eC9E -----END PGP SIGNATURE----- Net-Jifty-0.14/t/000755 000765 000024 00000000000 11510453206 014137 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/t/000-load.t000644 000765 000024 00000000672 11500226331 015541 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 3; use_ok 'Net::Jifty'; no warnings; *Net::Jifty::login = sub { 1 }; use warnings; my $j = Net::Jifty->new(site => 'http://mushroom.mu/', cookie_name => 'MUSHROOM_KINGDOM_SID', appname => 'MushroomKingdom', email => 'god@mushroom.mu', password => 'melange'); ok($j, "got a defined return value from Net::Jifty"); ok($j->isa('Net::Jifty'), "got a Net::Jifty object"); Net-Jifty-0.14/t/001-login.t000644 000765 000024 00000001546 11500226331 015734 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 6; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); my ($name, $args) = $j->ua->next_call(); is($name, "post", "the called method was post"); is($args->[1], "http://jifty.org/__jifty/webservices/yaml", "correct URL"); my $login = { 'J:A-fnord' => 'Login', 'J:A:F-address-fnord' => 'user@host.tld', 'J:A:F-password-fnord' => 'password', }; is_deeply($args->[2], $login, "correct login arguments"); is($j->sid, 'deadbeef', "get_sid was called"); # make sure we don't try to log in if we've already got a SID $j = Net::Jifty::Test->new(sid => "ababa"); ($name, $args) = $j->ua->next_call(); is($name, "cookie_jar", "didn't call post, but went right to cookie_jar"); ($name, $args) = $j->ua->next_call(); is($name, undef, "no other methods called"); Net-Jifty-0.14/t/002-method.t000644 000765 000024 00000004336 11500226331 016105 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 18; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); $j->ua->clear(); $j->get("ping"); my ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/ping.yml', 'correct URL'); $j->ua->clear; $j->get([qw/foo bar/]); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar.yml', 'correct URL with array-ref'); $j->ua->clear; $j->get("foo/bar"); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar.yml', 'correct URL with internal /'); $j->ua->clear; $j->get("foo/bar?baz=quux"); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar?baz=quux.yml', "correct URL. shouldn't try to pass arguments yourself"); $j->ua->clear; $j->get([qw{foo bar ?baz =quux}]); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar/%3Fbaz/%3Dquux.yml', 'URL is properly escaped when passed in as an array ref'); $j->ua->clear; $j->get([qw{foo bar ?baz =quux}]); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar/%3Fbaz/%3Dquux.yml', 'URL is properly escaped when passed in as an array ref'); $j->ua->clear; $j->get([qw{foo bar ?baz =quux}], arg => 1); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar/%3Fbaz/%3Dquux.yml?arg=1', '"get" query parameters work'); $j->ua->clear; $j->get([qw{foo bar ?baz =quux}], "?-?" => "=`="); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/foo/bar/%3Fbaz/%3Dquux.yml?%3F-%3F=%3D%60%3D', '"get" query parameters properly escaped'); $j->ua->clear; $j->get(["\x{2668}"], "\x{2668}" => "\x{2668}"); ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/%E2%99%A8.yml?%E2%99%A8=%E2%99%A8', '"get" query parameters properly encoded and escaped'); Net-Jifty-0.14/t/003-crud.t000644 000765 000024 00000003434 11500226331 015561 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 19; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); $j->ua->clear(); my %args = ( a => 'b', c => 'd', ); $j->create("Foo", %args); my ($name, $args) = $j->ua->next_call; is($name, 'request', 'used request for create'); isa_ok($args->[1], 'HTTP::Request', 'argument is an HTTP request'); is($args->[1]->method, 'POST', 'correct method (POST)'); is($args->[1]->uri, 'http://jifty.org/=/model/Foo.yml', 'correct URL'); like($args->[1]->content, qr/^(a=b&c=d|c=d&a=b)$/, 'correct arguments'); $j->ua->clear; $j->read("Foo", a => 'b'); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for read'); is_deeply($args->[1], 'http://jifty.org/=/model/Foo/a/b.yml', 'correct URL'); $j->ua->clear; $j->update("Foo", a => 'b', c => 'C', d => 'e'); ($name, $args) = $j->ua->next_call; is($name, 'request', 'used request for update'); isa_ok($args->[1], 'HTTP::Request', 'got an HTTP::Request object'); is($args->[1]->uri, 'http://jifty.org/=/model/Foo/a/b.yml', 'correct URL'); like($args->[1]->content, qr/^(?:c=C&d=e|d=e&c=C)$/, 'correct arguments'); $j->ua->clear; $j->delete("Foo", '"' => '?'); ($name, $args) = $j->ua->next_call; is($name, 'request', 'used request for delete'); isa_ok($args->[1], 'HTTP::Request', 'got an HTTP::Request object'); is($args->[1]->uri, 'http://jifty.org/=/model/Foo/%22/%3F.yml', 'correct URL'); $j->ua->clear; $j->act("Foo", '"' => '?'); ($name, $args) = $j->ua->next_call; is($name, 'request', 'used request for act'); isa_ok($args->[1], 'HTTP::Request', 'argument is an HTTP request'); is($args->[1]->method, 'POST', 'correct method (POST)'); is($args->[1]->uri, 'http://jifty.org/=/action/Foo.yml', 'correct URL'); is($args->[1]->content, '%22=%3F', 'correct argument'); Net-Jifty-0.14/t/004-search.t000644 000765 000024 00000002737 11500226331 016077 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 18; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); search('http://jifty.org/=/search/Foo/id/1/created/today.yml', "Foo", id => 1, created => "today"); search('http://jifty.org/=/search/Foo/id/1/id/2/created/today.yml', "Foo", id => 1, id => 2, created => "today"); search('http://jifty.org/=/search/Foo/id/1/id/2/created/today.yml', "Foo", id => [1, 2], created => "today"); search('http://jifty.org/=/search/Foo/id/1/created/today/out.yml', "Foo", id => 1, created => "today", "out"); search('http://jifty.org/=/search/Foo/id/1/id/2/created/today/out.yml', "Foo", id => 1, id => 2, created => "today", "out"); search('http://jifty.org/=/search/Foo/id/1/id/2/created/today/out.yml', "Foo", id => [1, 2], created => "today", "out"); search('http://jifty.org/=/search/Foo/id/1/id/2/id.yml', "Foo", id => [1, 2], "id"); search('http://jifty.org/=/search/Foo/id/1/id/2/id/3/id/4/id.yml', "Foo", id => [1, 2], id => [3, 4], "id"); search('http://jifty.org/=/search/Foo/id/1/id/2/inner/hi/id/3/id/4/id.yml', "Foo", id => [1, 2], inner => "hi", id => [3, 4], "id"); sub search { my $url = shift; my @args = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; $j->ua->clear; $j->search(@_); my ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called for search'); is($args->[1], $url, 'correct URL'); } Net-Jifty-0.14/t/005-validate.t000644 000765 000024 00000006647 11500226331 016430 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 31; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); $j->ua->clear(); my %args = ( a => 'b', c => 'd', ); $Net::Jifty::Test::content = << "YAML"; --- a: {} b: {} c: {} YAML $j->validate_action_args(["create", "Jifty::Model::Foo"], %args); my ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); $j->ua->clear; ok(delete $j->action_specs->{"CreateFoo"}, "cached spec"); $Net::Jifty::Test::content = << "YAML"; --- a: mandatory: 1 c: mandatory: 1 YAML $j->validate_action_args(["create", "Jifty::Model::Foo"], %args); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); $j->ua->clear; ok(delete $j->action_specs->{"CreateFoo"}, "cached spec"); $Net::Jifty::Test::content = << "YAML"; --- a: mandatory: 1 b: mandatory: 1 c: mandatory: 1 YAML eval { $j->validate_action_args("CreateFoo", %args) }; like($@, qr/^Mandatory argument 'b' not given for action CreateFoo\. at /); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); $j->ua->clear; ok(delete $j->action_specs->{"CreateFoo"}, "cached spec"); $Net::Jifty::Test::content = << "YAML"; --- a: mandatory: 1 b: {} YAML eval { $j->validate_action_args(["create", "Jifty::Model::Foo"], %args) }; like($@, qr/^Unknown arguments given for action CreateFoo: c at /); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); $j->ua->clear; ok(delete $j->action_specs->{"CreateFoo"}, "cached spec"); $j = Net::Jifty::Test->new(strict_arguments => 1); $j->ua->clear(); $Net::Jifty::Test::content = << "YAML"; --- c: {} YAML eval { $j->act("CreateFoo", %args) }; like($@, qr/^Unknown arguments given for action CreateFoo: a at /); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); $j->ua->clear; ok(delete $j->action_specs->{"CreateFoo"}, "cached spec"); $Net::Jifty::Test::content = << "YAML"; --- a: {} c: {} YAML $j->create("Jifty::Model::Foo", %args); ($name, $args) = $j->ua->next_call; is($name, 'get', 'used get for validation'); is($args->[1], 'http://jifty.org/=/action/CreateFoo.yml', 'correct URL'); ok($j->action_specs->{"CreateFoo"}, "cached spec"); ($name, $args) = $j->ua->next_call; is($name, 'request', 'used request for create'); isa_ok($args->[1], 'HTTP::Request', 'argument is an HTTP request'); is($args->[1]->method, 'POST', 'correct method (POST)'); is($args->[1]->uri, 'http://jifty.org/=/model/Jifty%3A%3AModel%3A%3AFoo.yml', 'correct URL'); like($args->[1]->content, qr/^(a=b&c=d|c=d&a=b)$/, 'correct arguments'); $j->ua->clear; $j->create("Jifty::Model::Foo", %args); ($name, $args) = $j->ua->next_call; is($name, 'request', 'used cache version of action spec'); isa_ok($args->[1], 'HTTP::Request', 'argument is an HTTP request'); is($args->[1]->method, 'POST', 'correct method (POST)'); is($args->[1]->uri, 'http://jifty.org/=/model/Jifty%3A%3AModel%3A%3AFoo.yml', 'correct URL'); like($args->[1]->content, qr/^(a=b&c=d|c=d&a=b)$/, 'correct arguments'); $j->ua->clear; Net-Jifty-0.14/t/006-uploads.t000644 000765 000024 00000010441 11510451006 016272 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 39; use lib 't/lib'; use Net::Jifty::Test; my $j = Net::Jifty::Test->new(); $j->ua->clear(); $j->get("ping"); my ($name, $args) = $j->ua->next_call(); is($name, 'get', 'ua->get method called'); is($args->[1], 'http://jifty.org/=/ping.yml', 'correct URL'); # all is set, no more fields, simple tests { $j->ua->clear; $j->post(['foo'], file => { content => 'stub', filename => 'test.txt', content_type => 'text/plain', } ); ($name, $args) = $j->ua->next_call(); is($name, 'request', 'ua->get method called'); my $req = $args->[1]; isa_ok($req, 'HTTP::Request'); is( $req->content_type, 'multipart/form-data', "multipart form data" ); my @parts = $req->parts; is( scalar @parts, 1, "has one part" ); is $parts[0]->content_type, 'text/plain', 'correct type of the part'; is $parts[0]->header('Content-Disposition'), 'form-data; name="file"; filename="test.txt"', 'checked disposition'; is $parts[0]->content, 'stub', 'checked content'; } # no type - defaults to octet-stream { $j->ua->clear; $j->post(['foo'], file => { content => 'stub', filename => 'test.txt', } ); ($name, $args) = $j->ua->next_call(); is($name, 'request', 'ua->get method called'); my $req = $args->[1]; isa_ok($req, 'HTTP::Request'); is( $req->content_type, 'multipart/form-data', "multipart form data" ); my @parts = $req->parts; is( scalar @parts, 1, "has one part" ); is $parts[0]->content_type, 'application/octet-stream', 'correct type of the part'; is $parts[0]->header('Content-Disposition'), 'form-data; name="file"; filename="test.txt"', 'checked disposition'; is $parts[0]->content, 'stub', 'checked content'; } # mix with another fields { $j->ua->clear; $j->post(['foo'], file => { content => 'stub', filename => 'test.txt', }, some_arg => 'some_value', ); ($name, $args) = $j->ua->next_call(); is($name, 'request', 'ua->get method called'); my $req = $args->[1]; isa_ok($req, 'HTTP::Request'); is( $req->content_type, 'multipart/form-data', "multipart form data" ); my @parts = $req->parts; is( scalar @parts, 2, "has two parts" ); is $parts[0]->content_type, 'application/octet-stream', 'correct type of the part'; is $parts[0]->header('Content-Disposition'), 'form-data; name="file"; filename="test.txt"', 'checked disposition'; is $parts[0]->content, 'stub', 'checked content'; is $parts[1]->header('Content-Disposition'), 'form-data; name="some_arg"', 'checked disposition'; is $parts[1]->content, 'some_value', 'checked content'; } # non ascii file name { $j->ua->clear; $j->post(['foo'], file => { content => 'stub', filename => "\x{442}.bin", } ); ($name, $args) = $j->ua->next_call(); is($name, 'request', 'ua->get method called'); my $req = $args->[1]; isa_ok($req, 'HTTP::Request'); is( $req->content_type, 'multipart/form-data', "multipart form data" ); my @parts = $req->parts; is( scalar @parts, 1, "has one part" ); is $parts[0]->content_type, 'application/octet-stream', 'correct type of the part'; is $parts[0]->header('Content-Disposition'), 'form-data; name="file"; filename="=?UTF-8?Q?=D1=82=2Ebin?="', 'checked disposition'; is $parts[0]->content, 'stub', 'checked content'; } # non ascii input type { $j->ua->clear; $j->post(['foo'], "\x{442}" => { content => 'stub', filename => "\x{442}.bin", } ); ($name, $args) = $j->ua->next_call(); is($name, 'request', 'ua->get method called'); my $req = $args->[1]; isa_ok($req, 'HTTP::Request'); is( $req->content_type, 'multipart/form-data', "multipart form data" ); my @parts = $req->parts; is( scalar @parts, 1, "has one part" ); is $parts[0]->content_type, 'application/octet-stream', 'correct type of the part'; is $parts[0]->header('Content-Disposition'), 'form-data; name="=?UTF-8?Q?=D1=82?="; filename="=?UTF-8?Q?=D1=82=2Ebin?="', 'checked disposition'; is $parts[0]->content, 'stub', 'checked content'; } Net-Jifty-0.14/t/lib/000755 000765 000024 00000000000 11510453206 014705 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/t/lib/Net/000755 000765 000024 00000000000 11510453206 015433 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/t/lib/Net/Jifty/000755 000765 000024 00000000000 11510453206 016520 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/t/lib/Net/Jifty/Test.pm000644 000765 000024 00000003120 11500226331 017765 0ustar00sartakstaff000000 000000 #!/usr/bin/env perl package Net::Jifty::Test; use Any::Moose; extends 'Net::Jifty'; use Test::MockObject; our $content_type = "text/x-yaml"; our $content = << "YAML"; --- fnord: success: 1 foo: 1 bar: 2 baz: 3 quux: - quuuux - quuuux Atreides: - Leto: male - Jessica: female - Paul: male - Alia: female YAML has '+ua' => ( default => sub { # the result object. change $Net::Jifty::Test::content to change the # results my $res = Test::MockObject->new; $res->set_bound(is_success => \$content); $res->set_bound(content => \$content); $res->set_bound(content_type => \$content_type); # the cookie object. the cookie name is hardcoded to JIFTY_SID my $cookie = Test::MockObject->new; $cookie->set_always(as_string => "JIFTY_SID=1010101"); $cookie->set_true('set_cookie'); my $mock = Test::MockObject->new; for (qw/get post head request/) { $mock->set_always($_ => $res); } $mock->set_always(cookie_jar => $cookie); $mock->set_isa('LWP::UserAgent'); return $mock; }, ); # give the rest of the attributes defaults for brevity has '+site' => ( default => 'http://jifty.org', ); has '+cookie_name' => ( default => 'JIFTY_SID', ); has '+appname' => ( default => 'JiftyApp', ); has '+email' => ( default => 'user@host.tld', ); has '+password' => ( default => 'password', ); # and override some methods sub get_sid { shift->sid("deadbeef"); } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Jifty-0.14/lib/Net/000755 000765 000024 00000000000 11510453206 015170 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/lib/Net/Jifty.pm000644 000765 000024 00000061461 11510453161 016623 0ustar00sartakstaff000000 000000 package Net::Jifty; use Any::Moose; our $VERSION = '0.14'; use LWP::UserAgent; use URI; use YAML; use Encode; use Fcntl qw(:mode); has site => ( is => 'rw', isa => 'Str', required => 1, documentation => "The URL of your application", trigger => sub { # this canonicalizes localhost to 127.0.0.1 because of an (I think) # HTTP::Cookies bug. cookies aren't sent out for localhost. my ($self, $site) = @_; if ($site =~ s/\blocalhost\b/127.0.0.1/) { $self->site($site); } }, ); has cookie_name => ( is => 'rw', isa => 'Str', required => 1, documentation => "The name of the session ID cookie. This can be found in your config under Framework/Web/SessinCookieName", ); has appname => ( is => 'rw', isa => 'Str', documentation => "The name of the application, as it is known to Jifty", ); has email => ( is => 'rw', isa => 'Str', documentation => "The email address to use to log in", ); has password => ( is => 'rw', isa => 'Str', documentation => "The password to use to log in", ); has sid => ( is => 'rw', isa => 'Str', documentation => "The session ID, from the cookie_name cookie. You can use this to bypass login", trigger => sub { my $self = shift; my $uri = URI->new($self->site); $self->ua->cookie_jar->set_cookie(0, $self->cookie_name, $self->sid, '/', $uri->host, $uri->port, 0, 0, undef, 1); }, ); has ua => ( is => 'rw', isa => 'LWP::UserAgent', default => sub { my $args = shift; my $ua = LWP::UserAgent->new; $ua->cookie_jar({}); push @{ $ua->requests_redirectable }, qw( POST PUT DELETE ); # Load the user's proxy settings from %ENV $ua->env_proxy; return $ua; }, ); has config_file => ( is => 'rw', isa => 'Str', default => "$ENV{HOME}/.jifty", predicate => 'has_config_file', documentation => "The place to look for the user's config file", ); has use_config => ( is => 'rw', isa => 'Bool', default => 0, documentation => "Whether or not to use the user's config", ); has config => ( is => 'rw', isa => 'HashRef', default => sub { {} }, documentation => "Storage for the user's config", ); has use_filters => ( is => 'rw', isa => 'Bool', default => 1, documentation => "Whether or not to use config files in the user's directory tree", ); has filter_file => ( is => 'rw', isa => 'Str', default => ".jifty", documentation => "The filename to look for in each parent directory", ); has strict_arguments => ( is => 'rw', isa => 'Bool', default => 0, documentation => "Check to make sure mandatory arguments are provided, and no unknown arguments are included", ); has action_specs => ( is => 'rw', isa => 'HashRef', default => sub { {} }, documentation => "The cache for action specifications", ); has model_specs => ( is => 'rw', isa => 'HashRef', default => sub { {} }, documentation => "The cache for model specifications", ); sub BUILD { my $self = shift; $self->load_config if $self->use_config && $self->has_config_file; $self->login unless $self->sid; } sub login { my $self = shift; return if $self->sid; confess "Unable to log in without an email and password." unless $self->email && $self->password; confess 'Your email did not contain an "@" sign. Did you accidentally use double quotes?' if $self->email !~ /@/; my $result = $self->call(Login => address => $self->email, password => $self->password); confess "Unable to log in." if $result->{failure}; $self->get_sid; return 1; } sub call { my $self = shift; my $action = shift; my %args = @_; my $moniker = 'fnord'; my $res = $self->ua->post( $self->site . "/__jifty/webservices/yaml", { "J:A-$moniker" => $action, map { ( "J:A:F-$_-$moniker" => $args{$_} ) } keys %args } ); if ( $res->is_success ) { return YAML::Load( Encode::decode_utf8($res->content) )->{$moniker}; } else { confess $res->status_line; } } sub form_url_encoded_args { my $self = shift; my $uri = ''; while (my ($key, $value) = splice @_, 0, 2) { $uri .= join('=', map { $self->escape($_) } $key, $value) . '&'; } chop $uri; return $uri; } sub form_form_data_args { my $self = shift; my @res; while (my ($key, $value) = splice @_, 0, 2) { my $disposition = 'form-data; name="'. Encode::encode( 'MIME-Q', $key ) .'"'; unless ( ref $value ) { push @res, HTTP::Message->new( ['Content-Disposition' => $disposition ], $value, ); next; } if ( $value->{'filename'} ) { $value->{'filename'} = Encode::encode( 'MIME-Q', $value->{'filename'} ); $disposition .= '; filename="'. delete ( $value->{'filename'} ) .'"'; } push @res, HTTP::Message->new( [ 'Content-Type' => $value->{'content_type'} || 'application/octet-stream', 'Content-Disposition' => $disposition, ], delete $value->{content}, ); } return @res; } sub method { my $self = shift; my $method = lc(shift); my $url = shift; my @args = @_; $url = $self->join_url(@$url) if ref($url) eq 'ARRAY'; # remove trailing / $url =~ s{/+$}{}; my $uri = $self->site . '/=/' . $url . '.yml'; my $res; if ($method eq 'get' || $method eq 'head') { $uri .= '?' . $self->form_url_encoded_args(@args) if @args; $res = $self->ua->$method($uri); } else { my $req = HTTP::Request->new( uc($method) => $uri, ); if (@args) { if ( grep ref $_, @args ) { $req->header('Content-type' => 'multipart/form-data'); $req->add_part( $_ ) foreach $self->form_form_data_args(@args); } else { $req->header('Content-type' => 'application/x-www-form-urlencoded'); $req->content( $self->form_url_encoded_args(@args) ); } } $res = $self->ua->request($req); # XXX Compensation for a bug in Jifty::Plugin::REST... it doesn't # remember to add .yml when redirecting after an update, so we will # try to do that ourselves... fixed in a Jifty coming to stores near # you soon! if ($res->is_success && $res->content_type eq 'text/html') { $req = $res->request->clone; $req->uri($req->uri . '.yml'); $res = $self->ua->request($req); } } if ($res->is_success) { return YAML::Load( Encode::decode_utf8($res->content) ); } else { confess $res->status_line; } } sub post { my $self = shift; $self->method('post', @_); } sub get { my $self = shift; $self->method('get', @_); } sub act { my $self = shift; my $action = shift; $self->validate_action_args($action => @_) if $self->strict_arguments; return $self->post(["action", $action], @_); } sub create { my $self = shift; my $model = shift; $self->validate_action_args([create => $model] => @_) if $self->strict_arguments; return $self->post(["model", $model], @_); } sub delete { my $self = shift; my $model = shift; my $key = shift; my $value = shift; $self->validate_action_args([delete => $model] => $key => $value) if $self->strict_arguments; return $self->method(delete => ["model", $model, $key, $value]); } sub update { my $self = shift; my $model = shift; my $key = shift; my $value = shift; $self->validate_action_args([update => $model] => $key => $value, @_) if $self->strict_arguments; return $self->method(put => ["model", $model, $key, $value], @_); } sub read { my $self = shift; my $model = shift; my $key = shift; my $value = shift; return $self->get(["model", $model, $key, $value]); } sub search { my $self = shift; my $model = shift; my @args; while (@_) { if (@_ == 1) { push @args, shift; } else { # id => [1,2,3] maps to id/1/id/2/id/3 if (ref($_[1]) eq 'ARRAY') { push @args, map { $_[0] => $_ } @{ $_[1] }; splice @_, 0, 2; } else { push @args, splice @_, 0, 2; } } } return $self->get(["search", $model, @args]); } sub validate_action_args { my $self = shift; my $action = shift; my %args = @_; my $name; if (ref($action) eq 'ARRAY') { my ($operation, $model) = @$action; # drop MyApp::Model:: $model =~ s/.*:://; confess "Invalid model operation: $operation. Expected 'create', 'update', or 'delete'." unless $operation =~ m{^(?:create|update|delete)$}i; $name = ucfirst(lc $operation) . $model; } else { $name = $action; } my $action_spec = $self->get_action_spec($name); for my $arg (keys %$action_spec) { confess "Mandatory argument '$arg' not given for action $name." if $action_spec->{$arg}{mandatory} && !defined($args{$arg}); delete $args{$arg}; } if (keys %args) { confess "Unknown arguments given for action $name: " . join(', ', keys %args); } return 1; } sub get_action_spec { my $self = shift; my $name = shift; unless ($self->action_specs->{$name}) { $self->action_specs->{$name} = $self->get("action/$name"); } return $self->action_specs->{$name}; } sub get_model_spec { my $self = shift; my $name = shift; unless ($self->model_specs->{$name}) { $self->model_specs->{$name} = $self->get("model/$name"); } return $self->model_specs->{$name}; } sub get_sid { my $self = shift; my $cookie = $self->cookie_name; my $sid; $sid = $1 if $self->ua->cookie_jar->as_string =~ /\Q$cookie\E=([^;]+)/; $self->sid($sid); } sub join_url { my $self = shift; return join '/', map { $self->escape($_) } grep { defined } @_ } sub escape { my $self = shift; return map { s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord $1)/eg; $_ } map { Encode::encode_utf8($_) } @_ } sub load_date { my $self = shift; my $ymd = shift; my ($y, $m, $d) = $ymd =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(?: 00:00:00)?$/ or confess "Invalid date passed to load_date: $ymd. Expected yyyy-mm-dd."; require DateTime; return DateTime->new( time_zone => 'floating', year => $y, month => $m, day => $d, ); } sub email_eq { my $self = shift; my $a = shift; my $b = shift; # if one's defined and the other isn't, return 0 return 0 unless (defined $a ? 1 : 0) == (defined $b ? 1 : 0); return 1 if !defined($a) && !defined($b); # so, both are defined require Email::Address; for ($a, $b) { $_ = 'nobody@localhost' if $_ eq 'nobody' || //; my ($email) = Email::Address->parse($_); $_ = lc($email->address); } return $a eq $b; } sub is_me { my $self = shift; my $email = shift; return 0 if !defined($email); return $self->email_eq($self->email, $email); } sub load_config { my $self = shift; $self->config_permissions; $self->read_config_file; # allow config to override everything. this may need to be less free in # the future while (my ($key, $value) = each %{ $self->config }) { $self->$key($value) if $self->can($key); } $self->prompt_login_info unless $self->config->{email} || $self->config->{sid}; # update config if we are logging in manually unless ($self->config->{sid}) { # if we have user/pass in the config then we still need to log in here unless ($self->sid) { $self->login; } # now write the new config $self->config->{sid} = $self->sid; $self->write_config_file; } return $self->config; } sub config_permissions { my $self = shift; my $file = $self->config_file; return if $^O eq 'MSWin32'; return unless -e $file; my @stat = stat($file); my $mode = $stat[2]; if ($mode & S_IRGRP || $mode & S_IROTH) { warn "Config file $file is readable by users other than you, fixing."; chmod 0600, $file; } } sub read_config_file { my $self = shift; my $file = $self->config_file; return unless -e $file; $self->config(YAML::LoadFile($self->config_file) || {}); if ($self->config->{site}) { # Somehow, localhost gets normalized to localhost.localdomain, # and messes up HTTP::Cookies when we try to set cookies on # localhost, since it doesn't send them to # localhost.localdomain. $self->config->{site} =~ s/localhost/127.0.0.1/; } } sub write_config_file { my $self = shift; my $file = $self->config_file; YAML::DumpFile($file, $self->config); chmod 0600, $file; } sub prompt_login_info { my $self = shift; print << "END_WELCOME"; Before we get started, please enter your @{[ $self->site ]} username and password. This information will be stored in @{[ $self->config_file ]}, should you ever need to change it. END_WELCOME local $| = 1; # Flush buffers immediately while (1) { print "First, what's your email address? "; $self->config->{email} = ; chomp($self->config->{email}); my $read_mode = eval { require Term::ReadKey; \&Term::ReadKey::ReadMode; } || sub {}; print "And your password? "; $read_mode->('noecho'); $self->config->{password} = ; chomp($self->config->{password}); $read_mode->('restore'); print "\n"; $self->email($self->config->{email}); $self->password($self->config->{password}); last if eval { $self->login }; $self->email(''); $self->password(''); print "That combination doesn't seem to be correct. Try again?\n"; } } sub filter_config { my $self = shift; return {} unless $self->use_filters; my $all_config = {}; require Path::Class; require Cwd; my $dir = Path::Class::dir(shift || Cwd::getcwd()); require Hash::Merge; my $old_behavior = Hash::Merge::get_behavior(); Hash::Merge::set_behavior('RIGHT_PRECEDENT'); while (1) { my $file = $dir->file( $self->filter_file )->stringify; if (-r $file) { my $this_config = YAML::LoadFile($file); $all_config = Hash::Merge::merge($this_config, $all_config); } my $parent = $dir->parent; last if $parent eq $dir; $dir = $parent; } Hash::Merge::set_behavior($old_behavior); return $all_config; } sub email_of { my $self = shift; my $id = shift; my $user = $self->read(User => id => $id); return $user->{email}; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; __END__ =head1 NAME Net::Jifty - interface to online Jifty applications =head1 SYNOPSIS use Net::Jifty; my $j = Net::Jifty->new( site => 'http://mushroom.mu/', cookie_name => 'MUSHROOM_KINGDOM_SID', email => 'god@mushroom.mu', password => 'melange', ); # the story begins $j->create(Hero => name => 'Mario', job => 'Plumber'); # find the hero whose job is Plumber and change his name to Luigi # and color to green $j->update(Hero => job => 'Plumber', name => 'Luigi', color => 'Green', ); # win! $j->delete(Enemy => name => 'Bowser'); =head1 DESCRIPTION L is a full-stack web framework. It provides an optional REST interface for applications. Using this module, you can interact with that REST interface to write client-side utilities. You can use this module directly, but you'll be better off subclassing it, such as what we've done for L. This module also provides a number of convenient methods for writing short scripts. For example, passing C<< use_config => 1 >> to C will look at the config file for the username and password (or SID) of the user. If neither is available, it will prompt the user for them. =head1 METHODS =head2 CRUD - create, read, update and delete. =head3 create MODEL, FIELDS Create a new object of type C with the C set. =head3 read MODEL, KEY => VALUE Find some C where C is C and return it. =head3 update MODEL, KEY => VALUE, FIELDS Find some C where C is C and set C on it. =head3 delete MODEL, KEY => VALUE Find some C where C is C and delete it. =head2 Other actions =head3 search MODEL, FIELDS[, OUTCOLUMN] Searches for all objects of type C that satisfy C. The optional C defines the output column, in case you don't want the entire records. =head3 act ACTION, ARGS Perform any C, using C. This does use the REST interface. =head2 Arguments of actions Arguments are treated as arrays with (name, value) pairs so you can do the following: $jifty->create('Model', x => 1, x => 2, x => 3 ); Some actions may require file uploads then you can use hash reference as value with content, filename and content_type fields. filename and content_type are optional. content_type by default is 'application/octeat-stream'. =head3 validate_action_args action => args Validates the given action, to check to make sure that all mandatory arguments are given and that no unknown arguments are given. Arguments are checked CRUD and act methods if 'strict_arguments' is set to true. You may give action as a string, which will be interpreted as the action name; or as an array reference for CRUD - the first element will be the action (create, update, or delete) and the second element will be the model name. This will throw an error or if validation succeeds, will return 1. =head2 Specifications of actions and models =head3 get_action_spec NAME Returns the action spec (which arguments it takes, and metadata about them). The first request for a particular action will ask the server for the spec. Subsequent requests will return it from the cache. =head3 get_model_spec NAME Returns the model spec (which columns it has). The first request for a particular model will ask the server for the spec. Subsequent requests will return it from the cache. =head2 Subclassing =head3 BUILD Each L object will do the following upon creation: =over 4 =item Read config ..but only if you C is set to true. =item Log in ..unless a sid is available, in which case we're already logged in. =back =head3 login This method is called automatically when each L object is constructed (unless a session ID is passed in). This assumes your site is using L. If that's not the case, override this in your subclass. =head3 prompt_login_info This will ask the user for her email and password. It may do so repeatedly until login is successful. =head3 call ACTION, ARGS This uses the Jifty "web services" API to perform C. This is I the REST interface, though it resembles it to some degree. This module currently only uses this to log in. =head2 Requests helpers =head3 post URL, ARGS This will post C to C. See the documentation for C about the format of C. =head3 get URL, ARGS This will get the specified C with C as query parameters. See the documentation for C about the format of C. =head3 method METHOD, URL[, ARGS] This will perform a C (GET, POST, PUT, DELETE, etc) using the internal L object. C may be a string or an array reference (which will have its parts properly escaped and joined with C). C already has C prepended to it, and C<.yml> appended to it, so you only need to pass something like C, or C<[qw/model YourApp.Model.Foo name]>. This will return the data structure returned by the Jifty application, or throw an error. =head3 form_url_encoded_args ARGS This will take an array containing (name, value) argument pairs and convert those arguments into URL encoded form. I.e., (x => 1, y => 2, z => 3) becomes: x=1&y=2&z=3 These are then ready to be appened to the URL on a GET or placed into the content of a PUT. However this method can not handle file uploads as they must be sent using 'multipart/form-date'. See also L and L. =head3 form_form_data_args ARGS This will take an array containing (name, value) argument pairs and convert those arguments into L objects ready for adding to a 'mulitpart/form-data' L as parts with something like: my $req = HTTP::Request->new( POST => $uri ); $req->header('Content-type' => 'multipart/form-data'); $req->add_part( $_ ) foreach $self->form_form_data_args( @args ); This method can handle file uploads, read more in L. See also L and L. =head3 join_url FRAGMENTS Encodes C and joins them with C. =head3 escape STRINGS Returns C, properly URI-escaped. =head2 Various helpers =head3 email_eq EMAIL, EMAIL Compares the two email addresses. Returns true if they're equal, false if they're not. =head3 is_me EMAIL Returns true if C looks like it is the same as the current user's. =head3 email_of ID Retrieve user C's email address. =head3 load_date DATE Loads C (which must be of the form C) into a L object. =head3 get_sid Retrieves the sid from the L object. =head2 Working with config =head3 load_config This will return a hash reference of the user's preferences. Because this method is designed for use in small standalone scripts, it has a few peculiarities. =over 4 =item It will C if the permissions are too liberal on the config file, and fix them. =item It will prompt the user for an email and password if necessary. Given the email and password, it will attempt to log in using them. If that fails, then it will try again. =item Upon successful login, it will write a new config consisting of the options already in the config plus session ID, email, and password. =back =head3 config_permissions This will warn about (and fix) config files being readable by group or others. =head3 read_config_file This transforms the config file into a hashref. It also does any postprocessing needed, such as transforming localhost to 127.0.0.1 (due to an obscure bug, probably in HTTP::Cookies). The config file is a L document that looks like: --- email: you@example.com password: drowssap sid: 11111111111111111111111111111111 =head3 write_config_file This will write the config to disk. This is usually only done when a sid is discovered, but may happen any time. =head3 filter_config [DIRECTORY] -> HASH Looks at the (given or) current directory, and all parent directories, for files named C<< $self->filter_file >>. Each file is YAML. The contents of the files will be merged (such that child settings override parent settings), and the merged hash will be returned. What this is used for is up to the application or subclasses. L doesn't look at this at all, but it may in the future (such as for email and password). =head1 SEE ALSO L, L =head1 AUTHORS Shawn M Moore, C<< >> Ruslan Zakirov, C<< >> Jesse Vincent, C<< >> =head1 CONTRIBUTORS Andrew Sterling Hanenkamp, C<< >>, =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. =head1 COPYRIGHT & LICENSE Copyright 2007-2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Net-Jifty-0.14/inc/Module/000755 000765 000024 00000000000 11510453206 015672 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/inc/Module/AutoInstall.pm000644 000765 000024 00000054231 11510453170 020474 0ustar00sartakstaff000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 Net-Jifty-0.14/inc/Module/Install/000755 000765 000024 00000000000 11510453206 017300 5ustar00sartakstaff000000 000000 Net-Jifty-0.14/inc/Module/Install.pm000644 000765 000024 00000030135 11510453170 017640 0ustar00sartakstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Net-Jifty-0.14/inc/Module/Install/AutoInstall.pm000644 000765 000024 00000003632 11510453170 022101 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } 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}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Net-Jifty-0.14/inc/Module/Install/Base.pm000644 000765 000024 00000002147 11510453170 020514 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Net-Jifty-0.14/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11510453171 020342 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Net-Jifty-0.14/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11510453171 020701 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Net-Jifty-0.14/inc/Module/Install/Include.pm000644 000765 000024 00000001015 11510453170 021216 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Net-Jifty-0.14/inc/Module/Install/Makefile.pm000644 000765 000024 00000027032 11510453170 021357 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 Net-Jifty-0.14/inc/Module/Install/Metadata.pm000644 000765 000024 00000043020 11510453170 021355 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Net-Jifty-0.14/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11510453171 020541 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Net-Jifty-0.14/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 11510453171 021372 0ustar00sartakstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;