Net-Google-Code-0.19/000755 000765 000120 00000000000 11366126703 015110 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/AUTHORS000644 000765 000120 00000000136 11330470212 016144 0ustar00sunnavyadmin000000 000000 In order of first commit: sunnavy Fayland Lam Net-Google-Code-0.19/Changes000644 000765 000120 00000005025 11366126647 016414 0ustar00sunnavyadmin000000 000000 Revision history for Net-Google-Code 0.19 Thu Apr 29 05:49:48 CST 2010 * google code changed summary page * fix the bug in cc extraction 0.18 Wed Apr 7 12:38:05 GMT 2010 * explicitly delete HTML::TreeBuilder object 0.17 Fri Jan 29 04:15:09 UTC 2010 * work around a weird bug of Mouse or even perl itself 0.16 Tue Dec 22 03:31:43 UTC 2009 * update issue part since google changed attachments snippet 0.15 Tue Oct 20 23:28:15 UTC 2009 * added fallback_to_search arg to updated_after so we can return asap if the quick way fails * added stars attribute for issue * fixed timezone: should be US/Pacific * don't set content if the content is bogus for issue comment * trim trailing spaces for description/content * initial implementation of Google's new API for Issues 0.14 Wed Jul 8 08:46:43 CST 2009 * google code changed Options page, so we changed our code correspondingly 0.13 Tue Jun 23 09:46:17 CST 2009 * Atom role => AtomParser class * decode utf8 more conservatively 0.12 Thu Jun 18 12:06:52 CST 2009 * refactor Issue::Search, added updated_after method for Issue::Search * added Predefined and Atom roles * switched from Moose to Any::Moose * converted DateTime from a role into a class * switched mech to be a single shared global and turn on the connection cache * removed the never used PropChange.pm 0.11 Wed May 27 11:38:06 CST 2009 bug fix version 0.10 Tue May 26 15:05:22 CST 2009 * simple write support for Issue * added reported, merged and updated attributes for Issue * added id and content_type attributes for Issue/Attachment * date attribute is changed from string to DateTime object 0.05 Thu May 14 16:00:07 CST 2009 * load_downloads doesn't parse feed any more, instead, it parses the downloads list page now. * added Role/Pageable.pm * removed Role.pm 0.04 Tue May 12 16:07:09 CST 2009 refactor version. CAVEAT: this release is not back compatible, the changes are: * lables are not parsed any more, now they're just an array ref with unparsed string, e.g. [ 'Pri-2', 'Mstone-X' ] * no Home.pm, its related functions are moved to Code.pm, see Net::Google::Code::load and Net::Google::Code::parse * no Downloads.pm, see Net::Google::Code::load_downloads and Net::Google::Code::Download * no WikiEntry.pm. see Net::Google::Code::load_wikis, the new Net::Google::Code::Wiki and Net::Google::Code::Wiki::Comment 0.03 Fri Apr 24 16:08:06 CST 2009 * mostly a bug fix version 0.02 added api for Downloads, Wiki and Home refactor a bit 0.01 Tue Jan 6 10:17:56 CST 2009 Initial release. Net-Google-Code-0.19/inc/000755 000765 000120 00000000000 11366126703 015661 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/000755 000765 000120 00000000000 11366126703 015656 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/Makefile.PL000644 000765 000120 00000001444 11330470212 017051 0ustar00sunnavyadmin000000 000000 use inc::Module::Install; use Getopt::Long; name 'Net-Google-Code'; all_from 'lib/Net/Google/Code.pm'; author 'sunnavy '; license 'perl'; test_requires 'Test::More'; test_requires 'Test::MockModule'; test_requires 'File::Slurp'; test_requires 'Test::Mock::LWP'; requires 'Any::Moose'; # requires 'WWW::Mechanize' doesn't work with Test::Mock::LWP requires 'WWW::Mechanize::Link'; requires 'HTML::TreeBuilder'; requires 'XML::FeedPP'; requires 'URI::Escape'; requires 'Params::Validate'; requires 'DateTime'; requires 'MIME::Types'; requires 'File::MMagic'; requires 'JSON'; my $live; GetOptions( 'live' => \$live ); if ($live) { tests('t/*.t t/*/*.t'); } else { tests('t/*.t t/google_api/*.t'); } recursive_author_tests('xt/'); auto_install; WriteAll; Net-Google-Code-0.19/MANIFEST000644 000765 000120 00000003353 11365741054 016246 0ustar00sunnavyadmin000000 000000 AUTHORS Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AuthorTests.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/Google/Code.pm lib/Net/Google/Code/AtomParser.pm lib/Net/Google/Code/DateTime.pm lib/Net/Google/Code/Download.pm lib/Net/Google/Code/Issue.pm lib/Net/Google/Code/Issue/Attachment.pm lib/Net/Google/Code/Issue/Base.pm lib/Net/Google/Code/Issue/Comment.pm lib/Net/Google/Code/Issue/Search.pm lib/Net/Google/Code/Issue/Util.pm lib/Net/Google/Code/Role/Authentication.pm lib/Net/Google/Code/Role/Fetchable.pm lib/Net/Google/Code/Role/HTMLTree.pm lib/Net/Google/Code/Role/Pageable.pm lib/Net/Google/Code/Role/Predefined.pm lib/Net/Google/Code/Role/URL.pm lib/Net/Google/Code/TypicalRoles.pm lib/Net/Google/Code/Wiki.pm lib/Net/Google/Code/Wiki/Comment.pm Makefile.PL MANIFEST This list of files META.yml README t/00.load.t t/02.issue.t t/03.comment.t t/04.attachment.t t/05.issue_search.t t/06.fetch.t t/10.downloads.t t/11.wiki.t t/20.code.t t/30.role_predefined.t t/google_api/01-issue.t t/google_api/02-comment.t t/google_api/data/comments.xml t/google_api/data/issue_8.html t/google_api/data/issue_8.xml t/google_api/data/issues.xml t/live/01.issue.t t/sample/02.issue.html t/sample/05.issue_search.html t/sample/05.issue_search.xml t/sample/06.fetch.html t/sample/10.download.html t/sample/11.TestPage.html t/sample/11.TestPage.wiki t/sample/11.wikis.html t/sample/20.code.downloads.html t/sample/20.code.html t/sample/30.role_predefined.js xt/kwalitee.t xt/perlcritic.t xt/pod-coverage.t xt/pod.t Net-Google-Code-0.19/META.yml000644 000765 000120 00000001410 11365741055 016357 0ustar00sunnavyadmin000000 000000 --- abstract: 'a simple client library for google code' author: - 'sunnavy ' build_requires: ExtUtils::MakeMaker: 6.42 File::Slurp: 0 Test::Mock::LWP: 0 Test::MockModule: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-Google-Code no_index: directory: - inc - t - xt requires: Any::Moose: 0 DateTime: 0 File::MMagic: 0 HTML::TreeBuilder: 0 JSON: 0 MIME::Types: 0 Params::Validate: 0 URI::Escape: 0 WWW::Mechanize::Link: 0 XML::FeedPP: 0 resources: license: http://dev.perl.org/licenses/ version: 0.18 Net-Google-Code-0.19/README000644 000765 000120 00000000704 11365741055 015773 0ustar00sunnavyadmin000000 000000 Net-Google-Code version 0.01 Net::Google::Code is a simple client library for projects hosted in Google Code. Patches would be gratefully appreciated. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/t/000755 000765 000120 00000000000 11366126703 015353 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/xt/000755 000765 000120 00000000000 11366126703 015543 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/xt/kwalitee.t000644 000765 000120 00000000263 11316340273 017531 0ustar00sunnavyadmin000000 000000 use Test::More; eval { require Test::Kwalitee; Test::Kwalitee->import( tests => ['-use_strict'] ); }; plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; Net-Google-Code-0.19/xt/perlcritic.t000644 000765 000120 00000000571 11316340273 020066 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More; # we forced use Perl::Critic is for version limit eval "use Perl::Critic 1.090; use Test::Perl::Critic 1.01"; if ($@) { plan skip_all => "Perl::Critic 1.090 and Test::Perl::Critic 1.01 required for testing PBP compliance"; } plan skip_all => "Perl::Critic does not support Any::Moose yet"; Test::Perl::Critic::all_critic_ok(); Net-Google-Code-0.19/xt/pod-coverage.t000644 000765 000120 00000000311 11316340273 020271 0ustar00sunnavyadmin000000 000000 use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok( { also_private => [ qr/^[A-Z_]+$/ ] } ); Net-Google-Code-0.19/xt/pod.t000644 000765 000120 00000000201 11316340273 016476 0ustar00sunnavyadmin000000 000000 use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Net-Google-Code-0.19/t/00.load.t000644 000765 000120 00000000654 11316340273 016675 0ustar00sunnavyadmin000000 000000 use Test::More; use File::Spec::Functions qw/catfile catdir/; use File::Basename qw( dirname ); my $manifest = catdir( dirname(__FILE__), '..', 'MANIFEST' ); plan skip_all => 'MANIFEST does not exist' unless -e $manifest; open FH, '<', $manifest; my @pms = map { s|^lib/||; chomp; $_ } grep { m|^lib/.*pm$| } ; plan tests => scalar @pms; for my $pm (@pms) { $pm =~ s|\.pm$||; $pm =~ s|/|::|g; use_ok($pm); } Net-Google-Code-0.19/t/02.issue.t000644 000765 000120 00000003545 11365736265 017130 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 20; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; my $content = read_file( "$Bin/sample/02.issue.html" ); utf8::downgrade( $content, 1 ); my $mock = Test::MockModule->new('Net::Google::Code::Issue'); $mock->mock( 'fetch', sub { $content } ); my $mock_att = Test::MockModule->new('Net::Google::Code::Issue::Attachment'); $mock_att->mock( 'fetch', sub { '' } ); use Net::Google::Code::Issue; my $issue = Net::Google::Code::Issue->new( project => 'test' ); isa_ok( $issue, 'Net::Google::Code::Issue', '$issue' ); $issue->load(8); my %info = ( id => 8, summary => 'issue 8', description => 'test the hack of file field', cc => 'sunnavy, t...@example.com', owner => 'sunnavy', reporter => 'sunnavy', status => 'Accepted', closed => undef, merged => undef, stars => 1, ); my @labels = ( 'Test-fine', ); for my $item ( qw/id summary description owner cc reporter status closed merged stars/ ) { if ( defined $info{$item} ) { is( $issue->$item, $info{$item}, "$item is extracted" ); } else { ok( !defined $issue->$item, "$item is not defined" ); } } is_deeply( $issue->labels, \@labels, 'labels is extracted' ); is( scalar @{$issue->comments}, 5, 'comments are extracted' ); is( $issue->comments->[0]->sequence, 0, 'comment 0 is for the actual create' ); is( scalar @{ $issue->comments->[0]->attachments }, 2, 'comment 0 has 2 attachments' ); is( $issue->comments->[1]->sequence, 1, 'sequence of comment 1 is 1' ); is( $issue->comments->[2]->sequence, 2, 'sequence of comment 2 is 4' ); is( scalar @{ $issue->attachments }, 2, 'attachments are extracted' ); is( $issue->attachments->[0]->size, '223 bytes', 'size of the 1st attachment' ); is( $issue->updated, '2009-10-14T12:07:40', 'updated' ); Net-Google-Code-0.19/t/03.comment.t000644 000765 000120 00000005655 11316340273 017431 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 9; use Net::Google::Code::Issue::Comment; use Test::MockModule; my $comment = Net::Google::Code::Issue::Comment->new( project => 'net-google-code' ); isa_ok( $comment, 'Net::Google::Code::Issue::Comment', '$comment' ); my $mock = Test::MockModule->new('Net::Google::Code::Issue::Attachment'); $mock->mock( 'fetch', sub { '' } ); my $content; { local $/; $content = ; } use HTML::TreeBuilder; my $tree = HTML::TreeBuilder->new; $tree->parse_content($content); $tree->elementify; $comment->parse( $tree ); my %info = ( sequence => 1, author => 'sunnavy', date => '2009-05-12T09:29:18', content => undef, ); for my $item ( keys %info ) { if ( defined $info{$item} ) { is( $comment->$item, $info{$item}, "$item is extracted" ); } else { ok( !defined $comment->$item, "$item is not defined" ); } } my $updates = { labels => ['-Priority-Medium'], }; is_deeply( $updates, $comment->updates, 'updates are extracted' ); is( scalar @{$comment->attachments}, 2, 'attachments are extracted' ); is( $comment->attachments->[0]->name, '/tmp/a', '1st attachment' ); is( $comment->attachments->[1]->name, '/tmp/b', '2nd attachment' ); __DATA__ Comment 1 by sunnavy, May 12, 2009 

(No comment was entered for this change.)
/tmp/a
3 bytes   Download
/tmp/b
5 bytes   Download
Labels: -Priority-Medium
Net-Google-Code-0.19/t/04.attachment.t000644 000765 000120 00000002662 11316340273 020113 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 7; use Test::MockModule; use Net::Google::Code::Issue::Attachment; my $attachment = Net::Google::Code::Issue::Attachment->new( project => 'test' ); isa_ok( $attachment, 'Net::Google::Code::Issue::Attachment', '$attachment' ); my $content; { local $/; $content = ; } my $mock = Test::MockModule->new('Net::Google::Code::Issue::Attachment'); $mock->mock( 'fetch', sub { 'ok' } ); $attachment->parse( $content ); my %info = ( url =>'http://net-google-code.googlecode.com/issues/attachment?aid=108689494720583752&name=%2Ftmp%2Fa', name => '/tmp/a', size => '3 bytes', id => '108689494720583752', content_type => 'text/plain', content => 'ok', ); for my $item ( keys %info ) { if ( defined $info{$item} ) { is ( $attachment->$item, $info{$item}, "$item is extracted" ); } else { ok( !defined $attachment->$item, "$item is not defined" ); } } __DATA__ /tmp/a
3 bytes   Download Net-Google-Code-0.19/t/05.issue_search.t000644 000765 000120 00000005733 11316340273 020443 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 37; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; my $html_content = read_file("$Bin/sample/05.issue_search.html"); my $xml_content = read_file("$Bin/sample/05.issue_search.xml"); my $mock = Test::MockModule->new('Net::Google::Code::Issue::Search'); $mock->mock( 'fetch', sub { my $self = shift; my $url = shift; if ( $url =~ /feeds/ ) { return $xml_content; } else { return $html_content; } } ); my $mock_mech = Test::MockModule->new('WWW::Mechanize'); $mock_mech->mock( 'title', sub { 'issues' } ); $mock_mech->mock( 'submit_form', sub { } ); $mock_mech->mock( 'is_success', sub { 1 } ); $mock_mech->mock( 'response', sub { HTTP::Response->new } ); my $mock_response = Test::MockModule->new('HTTP::Response'); $mock_response->mock( 'is_success', sub { 1 } ); $mock_response->mock( 'content', sub { $html_content } ); use Net::Google::Code::Issue::Search; my $search = Net::Google::Code::Issue::Search->new( project => 'test' ); isa_ok( $search, 'Net::Google::Code::Issue::Search', '$search' ); # search tests can_ok( $search, 'search' ); $search->search(load_after_search => 0); is( scalar @{ $search->results }, 8, 'results number in total' ); my %first_result = ( 'owner' => 'sunnavy', 'attachments' => [], 'summary' => 'labels', 'status' => 'Accepted', 'project' => 'test', 'id' => '2', 'labels' => [], 'comments' => [] ); for my $key ( keys %first_result ) { is_deeply( $search->results->[0]->$key, $first_result{$key}, "first result $key" ); } is_deeply( $search->results->[-1]->labels, [qw/0.05 blabla/], 'last result labels' ); # updated_after tests can_ok( $search, 'updated_after' ); my $mock_issue = Test::MockModule->new('Net::Google::Code::Issue'); $mock_issue->mock( 'load', sub { my $id = shift->id; ok( 1, "load( $id ) is called" ); } ); my $dt = DateTime->new( year => 2009, month => 6, day => 1 ); my $issues = $search->updated_after( $dt ); my @ids = map { $_->id } @$issues; is_deeply( \@ids, [ 22, 13, 14, 10 ], 'updated_after 2009-06-01 got 4 issues' ); $dt = DateTime->new( year => 2010, month => 1, day => 1 ); $issues = $search->updated_after( $dt ); is_deeply( $issues, [ ], 'updated_after 2010-01-01 got 0 issues' ); # let updated_after call ->search $dt = DateTime->new( year => 2008, month => 1, day => 1 ); my $updated = DateTime->new( year => 2010, month => 1, day => 1 ); $mock_issue->mock( 'updated', sub { $updated } ); $issues = $search->updated_after( $dt ); is( scalar @{ $search->results }, 8, 'downgraded to ->search to find issues' ); $updated = DateTime->new( year => 2005, month => 1, day => 1 ); $mock_issue->mock( 'updated', sub { $updated } ); $issues = $search->updated_after( $dt ); is( scalar @{ $search->results }, 0, 'downgraded updated_after version also filters by the updated date' ); Net-Google-Code-0.19/t/06.fetch.t000644 000765 000120 00000001557 11316340273 017060 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 2; use Test::MockModule; # test the decode stuff in fetch use FindBin qw/$Bin/; use File::Slurp; use Encode; my $content = read_file("$Bin/sample/06.fetch.html"); my $mock_mech = Test::MockModule->new('WWW::Mechanize'); $mock_mech->mock( 'get', sub { } ); $mock_mech->mock( 'is_success', sub { 1 } ); $mock_mech->mock( 'response', sub { HTTP::Response->new } ); $mock_mech->mock( 'content', sub { $content } ); my $mock_response = Test::MockModule->new('HTTP::Response'); $mock_response->mock( 'is_success', sub { 1 } ); use Net::Google::Code::Issue; my $issue = Net::Google::Code::Issue->new( project => 'test' ); isa_ok( $issue, 'Net::Google::Code::Issue', '$issue' ); $issue->load(487); my $summary = 'Can´t get K9 to work with Exchange Account'; is( $issue->summary, $summary, 'summary is extracted' ); Net-Google-Code-0.19/t/10.downloads.t000644 000765 000120 00000002514 11316340273 017746 0ustar00sunnavyadmin000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 10; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; use Net::Google::Code; my $down_file = "$Bin/sample/10.download.html"; my $download_content = read_file($down_file); my $mock_downloads = Test::MockModule->new('Net::Google::Code::Download'); $mock_downloads->mock( 'fetch', sub { $download_content } ); my $download = Net::Google::Code::Download->new( project => 'net-google-code', name => 'Net-Google-Code-0.01.tar.gz', ); $download->load; is( $download->name, 'Net-Google-Code-0.01.tar.gz', 'name is set' ); is( $download->size, '37.4 KB', 'size is parsed' ); is( $download->count, 16, 'count is parsed' ); is( scalar @{ $download->labels }, 2, 'labels number' ); is( $download->labels->[0], '0.01', '1st label is parsed' ); is( $download->labels->[1], 'simple', '2nd label is parsed' ); is( $download->checksum, '5073de2276f916cf5d74d7abfd78a463e15674a1', 'checksum is parsed' ); is( $download->download_url, 'http://net-google-code.googlecode.com/files/Net-Google-Code-0.01.tar.gz', 'download_url is parsed' ); is( $download->uploaded_by, 'sunnavy', 'uploaded_by is parsed' ); is( $download->uploaded, 'Tue Jan 6 00:16:06 2009', 'uploaded is parsed' ); 1; Net-Google-Code-0.19/t/11.wiki.t000644 000765 000120 00000003447 11316340273 016726 0ustar00sunnavyadmin000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 15; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; use Net::Google::Code; my $svn_file = "$Bin/sample/11.TestPage.wiki"; my $svn_content = read_file( $svn_file ); my $wiki_file = "$Bin/sample/11.TestPage.html"; use Net::Google::Code::Wiki; my $mock_wiki = Test::MockModule->new('Net::Google::Code::Wiki'); $mock_wiki->mock( 'fetch', sub { shift; my $url = shift; if ( $url =~ /svn/ ) { $svn_content; } else { read_file($wiki_file); } } ); my $wiki = Net::Google::Code::Wiki->new( project => 'net-google-code', name => 'TestPage', ); isa_ok( $wiki, 'Net::Google::Code::Wiki' ); is( $wiki->name, 'TestPage', 'name' ); $wiki->load; # test source is( $wiki->source, $svn_content, 'source' ); is( $wiki->summary, 'One-sentence summary of this page.', 'summary is parsed' ); is_deeply( $wiki->labels, [ 'Phase-QA', 'Phase-Support' ], 'labels are parsed' ); is( $wiki->updated, 'Sat Jan 17 15:21:27 2009', 'updated is parsed' ); is( $wiki->updated_by, 'fayland', 'updated_by is parsed' ); like( $wiki->content, qr/

Add your content here/, 'content is parsed' ); is( scalar @{$wiki->comments}, 2, '2 comments' ); my $comments = $wiki->comments; is( $comments->[0]->author, 'fayland', '1st comment author is parsed' ); is( $comments->[0]->date, 'Wed Jan 7 22:37:57 2009', '1st comment date is parsed' ); is( $comments->[0]->content, 'comment1', '1st comment content is parsed' ); is( $comments->[1]->author, 'fayland', '2nd comment author is parsed' ); is( $comments->[1]->date, 'Wed Jan 7 22:38:07 2009', '2nd comment date is parsed' ); is( $comments->[1]->content, 'two line comment 2.', '2nd comment content is parsed' ); 1; Net-Google-Code-0.19/t/20.code.t000644 000765 000120 00000005071 11365162777 016707 0ustar00sunnavyadmin000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 19; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; use_ok('Net::Google::Code'); my $homepage_file = "$Bin/sample/20.code.html"; my $downloads_file = "$Bin/sample/20.code.downloads.html"; my $download_file = "$Bin/sample/10.download.html"; my $wikis_file = "$Bin/sample/11.wikis.html"; my $wiki_svn_file = "$Bin/sample/11.TestPage.wiki"; my $wiki_file = "$Bin/sample/11.TestPage.html"; my $mock = Test::MockModule->new('Net::Google::Code'); $mock->mock( 'fetch', sub { shift; my $url = shift; if ( $url =~ /downloads/ ) { read_file( $downloads_file ); } elsif ( $url =~ /wiki/ ) { read_file( $wikis_file ); } else { read_file( $homepage_file ); } } ); my $mock_downloads = Test::MockModule->new('Net::Google::Code::Download'); $mock_downloads->mock( 'fetch', sub { read_file($download_file) } ); my $name = 'net-google-code'; my $project = Net::Google::Code->new( project => $name ); is( $project->base_url, "http://code.google.com/p/$name/", 'default url' ); is( $project->base_svn_url, "http://$name.googlecode.com/svn/", 'svn url' ); is( $project->project, $name, 'project name' ); $project->load; is_deeply( $project->owners, ['sunnavy'] ); is_deeply( $project->members, [ 'jessev', 'fayland' ] ); like $project->description, qr/Net\:\:Google\:\:Code/; is_deeply( $project->labels, [ 'perl' ] ); is $project->summary, 'a simple client library for google code'; isa_ok( $project->issue, 'Net::Google::Code::Issue' ); isa_ok( $project->download, 'Net::Google::Code::Download' ); isa_ok( $project->wiki, 'Net::Google::Code::Wiki' ); # test downloads $project->load_downloads; is( scalar @{ $project->downloads }, 2, 'have 2 downloads' ); my $download = $project->downloads->[1]; isa_ok( $download, 'Net::Google::Code::Download' ); is( $download->name, 'Net-Google-Code-0.01.tar.gz', 'download name' ); is( $download->size, '37.4 KB', 'download size' ); # test wikis my $mock_wiki = Test::MockModule->new('Net::Google::Code::Wiki'); $mock_wiki->mock( 'fetch', sub { shift; my $url = shift; if ( $url =~ /svn/ ) { read_file($wiki_svn_file); } else { read_file($wiki_file); } } ); $project->load_wikis; is( scalar @{ $project->wikis }, 1, 'have 1 wiki' ); my $wiki = $project->wikis->[0]; is( $wiki->name, 'TestPage', 'wiki name' ); is( $wiki->summary, 'One-sentence summary of this page.', 'wiki summary' ); Net-Google-Code-0.19/t/30.role_predefined.t000644 000765 000120 00000003156 11316340273 021107 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 3; use Test::MockModule; use FindBin qw/$Bin/; use File::Slurp; my $content = read_file("$Bin/sample/30.role_predefined.js"); my $mock = Test::MockModule->new('Net::Google::Code::Issue'); $mock->mock( 'fetch', sub { q{codesite_token = "faked_token" } } ); $mock->mock( 'signed_in', sub { 1 } ); my $mock_mech = Test::MockModule->new('WWW::Mechanize'); $mock_mech->mock( 'content', sub { $content } ); $mock_mech->mock( 'update_html', sub { } ); $mock_mech->mock( 'submit_form', sub { } ); $mock_mech->mock( 'success', sub { 1 } ); use Net::Google::Code::Issue; my $issue = Net::Google::Code::Issue->new( project => 'test' ); ok( $issue->load_predefined, 'loaded predefined' ); is_deeply( $issue->predefined_labels, [ 'Type-Defect', 'Type-Enhancement', 'Type-Task', 'Type-Review', 'Type-Other', 'Priority-Critical', 'Priority-High', 'Priority-Medium', 'Priority-Low', 'OpSys-All', 'OpSys-Windows', 'OpSys-Linux', 'OpSys-OSX', 'Milestone-Release1.0', 'Component-UI', 'Component-Logic', 'Component-Persistence', 'Component-Scripts', 'Component-Docs', 'Security', 'Performance', 'Usability', 'Maintainability', ], 'predefined labels' ); is_deeply( $issue->predefined_status, { 'closed' => [ 'Fixed', 'Verified', 'Invalid', 'Duplicate', 'WontFix', 'Done', ], 'open' => [ 'New', 'Accepted', 'Started', ], }, 'predefined status' ); Net-Google-Code-0.19/t/google_api/000755 000765 000120 00000000000 11366126703 017460 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/t/live/000755 000765 000120 00000000000 11366126703 016312 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/t/sample/000755 000765 000120 00000000000 11366126703 016634 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/t/sample/02.issue.html000644 000765 000120 00000037015 11316340273 021073 0ustar00sunnavyadmin000000 000000 Issue 8 - net-google-code - issue 8 - Project Hosting on Google Code

Project Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
New issue | Search
for
| Advanced search | Search tips
Issue 8: issue 8
1 person starred this issue and may be notified of changes. Back to list
Status:  Accepted
Owner:  sunnavy
Cc:  sunnavy, t...@example.com
Test-fine


Sign in to add a comment
 
Reported by sunnavy, Feb 20, 2009 
test the hack of file field
/tmp/aaa
223 bytes   Download
/tmp/xx.pdf
6.1 KB   Download
Comment 1 by sunnavy, Oct 12, 2009 
(No comment was entered for this change.)
Summary: test attachment 8
Comment 2 by sunnavy, Oct 13, 2009 
(No comment was entered for this change.)
Cc: sunnavy
Comment 3 by sunnavy, Oct 13, 2009 
(No comment was entered for this change.)
Cc: t...@example.com
Comment 4 by sunnavy, Oct 14, 2009 
comment with published hybrid version
Summary: issue 8
Sign in to add a comment

Hosted by Google Code
Net-Google-Code-0.19/t/sample/05.issue_search.html000644 000765 000120 00000117513 11316340273 022425 0ustar00sunnavyadmin000000 000000 Issues - net-google-code - Google Code
sunnavy@gmail.com | My favorites | Profile | Sign out
Project Logo
Project hosting will be READ-ONLY Tuesday at 11am PDT due to brief network maintenance.
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
  
Administer
 
New issue | Search
for
| Advanced search | Search tips
Tip: Type ? for issue tracker keyboard shortcut help. hide
List | Grid
Select: All None       
  ID Type Status Priority Milestone Owner   Summary + Labels ...
2 ---- Accepted ---- ---- sunnavy › labels  
4 Defect Accepted Medium ---- sunnavy › test the result page  
5 Defect Accepted ---- ---- sunnavy › labels  
6 Defect Accepted ---- ---- sunnavy › labels  
7 Defect Accepted ---- ---- sunnavy › labels  
8 ---- Accepted ---- ---- sunnavy › test attachment  
9 Defect Accepted ---- ---- sunnavy › test filesThu May 14 11:39:06 2009   0.05  
10 Defect Accepted ---- ---- sunnavy › not touch labels   0.05 blabla  
CSV
  
Show columns:
 ♦ ID
 ♦ Type
 ♦ Status
 ♦ Priority
 ♦ Milestone
 ♦ Owner
 ♦ Summary
    Stars
    Opened
    Closed
    Modified
    BlockedOn
    Blocking
    Blocked
    MergedInto
    Reporter
    Cc
    Test
    Label
    Opsys
    Edit column spec...
Hosted by Google Code
Net-Google-Code-0.19/t/sample/05.issue_search.xml000644 000765 000120 00000023765 11316340273 022266 0ustar00sunnavyadmin000000 000000 2009-06-12T05:55:48Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic Issue updates for project net-google-code on Google Code 2009-06-12T05:55:48Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/22/2 Update 2 to issue 22 ("for sd test") sunnavy <pre>second comment </pre> 2009-06-12T05:55:22Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/22/1 Update 1 to issue 22 ("for sd test") sunnavy <pre>first comment </pre> 2009-06-12T05:55:06Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/22 Issue 22 created: "for sd test" sunnavy <pre>this is description </pre> 2009-06-04T05:35:33Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/13/4 Update 4 to issue 13 ("Enter one-line summary") sunnavy <pre>test 2 </pre> 2009-06-04T05:34:42Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/13/3 Update 3 to issue 13 ("Enter one-line summary") sunnavy <pre>test 2 </pre> 2009-06-04T05:34:41Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/13/2 Update 2 to issue 13 ("Enter one-line summary") sunnavy <pre>test 1 </pre> 2009-06-04T05:02:17Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/13/1 Update 1 to issue 13 ("Enter one-line summary") sunnavy <pre>06-04 13:02 CST </pre> 2009-06-03T11:32:10Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/12 Update 12 to issue 14 ("sd1") sunnavy <pre> <br/>Blockedon: 23 </pre> 2009-06-02T00:34:20Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/10/16 Update 16 to issue 10 ("not touch labels") sunnavy <pre>Issue 14 has been merged into this issue. </pre> 2009-06-02T00:34:20Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/11 Update 11 to issue 14 ("sd1") sunnavy <pre> <br/>Status: Duplicate<br/>Mergedinto: 10<br/>Blockedon: -10 </pre> 2009-06-02T00:33:32Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/10 Update 10 to issue 14 ("sd1") sunnavy <pre> <br/>Blockedon: 10 </pre> 2009-05-27T03:24:40Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/9 Update 9 to issue 14 ("sd1") sunnavy <pre> <br/>Summary: sd1 </pre> 2009-05-27T02:45:04Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/8 Update 8 to issue 14 ("sd1 test") sunnavy <pre> <br/>Summary: sd1 test<br/>Labels: -priority-critical -test -bool 3 </pre> 2009-05-27T02:40:29Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/7 Update 7 to issue 14 ("sd1") sunnavy <pre> <br/>Labels: -Priority-Medium priority-critical ok test bool </pre> 2009-05-27T02:19:57Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/6 Update 6 to issue 14 ("sd1") sunnavy <pre> this is comment </pre> 2009-05-27T02:12:57Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/5 Update 5 to issue 14 ("sd1") sunnavy <pre> bla </pre> 2009-05-27T01:03:29Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/4 Update 4 to issue 14 ("sd1") sunnavy <pre>test attachment </pre> 2009-05-26T15:34:05Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/3 Update 3 to issue 14 ("sd1") sunnavy <pre>heya! </pre> 2009-05-26T15:00:28Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/bulk 7 issues changed in net-google-code sunnavy <pre>Updates: Status: Duplicate Comment by sunnavy: (No comment was entered for this change.) Affected issues: issue 15: test sd push http://code.google.com/p/net-google-code/issues/detail?id=15 issue 16: test sd push http://code.google.com/p/net-google-code/issues/detail?id=16 issue 17: test sd push http://code.google.com/p/net-google-code/issues/detail?id=17 issue 18: test sd push http://code.google.com/p/net-google-code/issues/detail?id=18 issue 19: test sd push http://code.google.com/p/net-google-code/issues/detail?id=19 issue 20: test sd push http://code.google.com/p/net-google-code/issues/detail?id=20 issue 21: test sd push http://code.google.com/p/net-google-code/issues/detail?id=21 </pre> 2009-05-26T14:59:34Z http://code.google.com/feeds/p/net-google-code/issueupdates/basic/14/2 Update 2 to issue 14 ("sd1") sunnavy <pre> <br/>Summary: sd1 </pre> Net-Google-Code-0.19/t/sample/06.fetch.html000644 000765 000120 00000033564 11316340273 021045 0ustar00sunnavyadmin000000 000000 Issue 487 - k9mail - Can´t get K9 to work with Exchange Account - Google Code
Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
New issue | Search
for
| Advanced search | Search tips
Issue 487: Can´t get K9 to work with Exchange Account
2 people starred this issue and may be notified of changes. Back to list
Status:  New
Owner:  ----
Type-Defect
Priority-Medium
Product-k9mail


Sign in to add a comment

 
Reported by ro.hammerl, Jun 10, 2009 
What steps will reproduce the problem?
1. Start K9
2. Enter account details for my Exchange Account
3. K9 tries to sync, stops without any visible error

What is the expected output? What do you see instead?

Expected Output is a list of my email. I see a blank page as K9 tries to
connect/sync with my exchange server, but it does not work

What version of K-9 are you using?

0.114

Is your email account a POP account or an IMAP account?

Exchange Account. 

Does this problem also occur on the built in 'Email' client?

No, has no exchange support. The account works with Touchdown and Moxier Mail.

Please provide any additional information below.

I already use Touchdown for the company exchange account. Now I need a
second software for a second exchange account. I enter username, Passwort
and Adress of OWA in the settings. I do not know what to enter at the other
settings (mailbox path, ...)

I enter the Details and afterwards it tries to connect and sync (see right
top corner a ring moving for loading). Nothing happens - no emails and no
error message.

I tried both accounts where I know they work with other software on Android.

Is there a tutorial for Exchange Support? What am I doing wrong?
Comment 1 by danapple0, Jun 10, 2009 
Please look in the K9mail-errors folder, if there is one.  If so, please extract the
message there and add it to this issue.
Comment 2 by bwbrown, Jun 10, 2009 
There is no tutorial as far as I know.  I have a similar issue (#483) and I am
waiting for an answer too.  It would be great if there was a tutorial or someone just
said hey it doesn't work with exchange. Either way then we would know what to do.
Comment 3 by ro.hammerl, Jun 12, 2009 
Hi, Unfortunately there is no errors-folder :(
Sign in to add a comment

Hosted by Google Code
Net-Google-Code-0.19/t/sample/10.download.html000644 000765 000120 00000021263 11316340273 021547 0ustar00sunnavyadmin000000 000000 Net-Google-Code-0.01.tar.gz - net-google-code - Net-Google-Code-0.01 - Google Code
Project Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
Search
for
 Download: Net-Google-Code-0.01
 
Uploaded by:  sunnavy
Uploaded:  Jan 06, 2009
Downloads: 16
0.01
simple



SHA1 Checksum: 5073de2276f916cf5d74d7abfd78a463e15674a1
Tip: Use the SHA1 checksum shown to verify file integrity.



Hosted by Google Code
Net-Google-Code-0.19/t/sample/11.TestPage.html000644 000765 000120 00000027035 11316340273 021460 0ustar00sunnavyadmin000000 000000 TestPage - net-google-code - One-sentence summary of this page. - Google Code
xxx@gmail.com | What's new? | Profile | Settings | Help | Sign out
Google
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
New Page | Search
for
| Edit This Page | Delete This Page

Comment by fayland, Jan 07, 2009

comment1

Comment by fayland, Jan 07, 2009

two line comment 2.

Enter a comment:
show hide Wiki Markup Help
=Heading1=
==Heading2==
===Heading3===

*bold*     _italic_
`inline code`
escape: `*`

Indent lists 2 spaces:
  * bullet item
  # numbered list

{{{
verbatim code block
}}}

Horizontal rule
----

WikiWordLink
[http://domain/page label]
http://domain/page

|| table || cells ||

More examples
Net-Google-Code-0.19/t/sample/11.TestPage.wiki000644 000765 000120 00000000440 11316340273 021446 0ustar00sunnavyadmin000000 000000 #summary One-sentence summary of this page. #labels Phase-QA,Phase-Support = Introduction = Add your content here. = Details = Add your content here. Format your content with: * Text in *bold* or _italic_ * Headings, paragraphs, and lists * Automatic links to other wiki pagesNet-Google-Code-0.19/t/sample/11.wikis.html000644 000765 000120 00000001031 11316340273 021056 0ustar00sunnavyadmin000000 000000 net-google-code - Revision 6: /wiki

net-google-code - Revision 6: /wiki

Google Code powered by Subversion Net-Google-Code-0.19/t/sample/20.code.downloads.html000644 000765 000120 00000045626 11316340273 022655 0ustar00sunnavyadmin000000 000000 Downloads - net-google-code - Google Code
sunnavy@gmail.com | My favorites | Profile | Sign out
Project Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
  
Administer
 
New download | Search
for
  
  Filename Summary + Labels Uploaded Size DownloadCount ...
Net-Google-Code-0.04.tar.gz Net-Google-Code-0.04   0.04 60 minutes ago 48.0 KB 0  
Net-Google-Code-0.01.tar.gz Net-Google-Code-0.01   0.01 simple Jan 06 37.4 KB 16  
  
Show columns:
 ♦ Filename
 ♦ Summary
 ♦ Uploaded
 ♦ Size
 ♦ DownloadCount
    UploadedBy
    Edit column spec...
Hosted by Google Code
Net-Google-Code-0.19/t/sample/20.code.html000644 000765 000120 00000023700 11365162712 020655 0ustar00sunnavyadmin000000 000000 net-google-code - Project Hosting on Google Code
Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
Summary | Updates | People
Activity: None
Code license:
Artistic License/GPL
Labels:
perl
Feeds:
Project feeds
Owners:
sunnavy
Committers:
jessev, fayland
People details »

Net::Google::Code is a simple client library for projects hosted in Google Code.

Currently, it focuses on the issue tracker, and the basic read functionality for that is provided.









Powered by Google Project Hosting
Net-Google-Code-0.19/t/sample/30.role_predefined.js000644 000765 000120 00000004342 11316340273 022537 0ustar00sunnavyadmin000000 000000 {"members":[{"doc":"","name":"sunnavy"},{"doc":"","name":"jessev"},{"doc":"","name":"fayland"}],"excl_prefixes":["type","priority","milestone"],"labels":[{"doc":"Report of a software defect","name":"Type-Defect"},{"doc":"Request for enhancement","name":"Type-Enhancement"},{"doc":"Work item that doesn't change the code or docs","name":"Type-Task"},{"doc":"Request for a source code review","name":"Type-Review"},{"doc":"Some other kind of issue","name":"Type-Other"},{"doc":"Must resolve in the specified milestone","name":"Priority-Critical"},{"doc":"Strongly want to resolve in the specified milestone","name":"Priority-High"},{"doc":"Normal priority","name":"Priority-Medium"},{"doc":"Might slip to later milestone","name":"Priority-Low"},{"doc":"Affects all operating systems","name":"OpSys-All"},{"doc":"Affects Windows users","name":"OpSys-Windows"},{"doc":"Affects Linux users","name":"OpSys-Linux"},{"doc":"Affects Mac OS X users","name":"OpSys-OSX"},{"doc":"All essential functionality working","name":"Milestone-Release1.0"},{"doc":"Issue relates to program UI","name":"Component-UI"},{"doc":"Issue relates to application logic","name":"Component-Logic"},{"doc":"Issue relates to data storage components","name":"Component-Persistence"},{"doc":"Utility and installation scripts","name":"Component-Scripts"},{"doc":"Issue relates to end-user documentation","name":"Component-Docs"},{"doc":"Security risk to users","name":"Security"},{"doc":"Performance issue","name":"Performance"},{"doc":"Affects program usability","name":"Usability"},{"doc":"Hinders future changes","name":"Maintainability"}],"statuses_offer_merge":["Duplicate"],"strict":false,"closed":[{"doc":"Developer made source code changes, QA should verify","name":"Fixed"},{"doc":"QA has verified that the fix worked","name":"Verified"},{"doc":"This was not a valid issue report","name":"Invalid"},{"doc":"This report duplicates an existing issue","name":"Duplicate"},{"doc":"We decided to not take action on this issue","name":"WontFix"},{"doc":"The requested non-coding task was completed","name":"Done"}],"open":[{"doc":"Issue has not had initial review yet","name":"New"},{"doc":"Problem reproduced / Need acknowledged","name":"Accepted"},{"doc":"Work on this issue has begun","name":"Started"}]} Net-Google-Code-0.19/t/live/01.issue.t000644 000765 000120 00000001025 11316340273 020037 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 13; use Net::Google::Code::Issue; my $issue = Net::Google::Code::Issue->new( project => 'net-google-code' ); isa_ok( $issue, 'Net::Google::Code::Issue', '$issue' ); for my $id ( 8 .. 9 ) { ok( $issue->load($id) ); # to make sure $_->content can be called continuously ok( $_->content ) for @{ $issue->attachments }; } $Net::Google::Code::Issue::USE_HYBRID = 1; for my $id ( 8 .. 9 ) { ok( $issue->load($id) ); ok( $_->content ) for @{ $issue->attachments }; } Net-Google-Code-0.19/t/google_api/01-issue.t000644 000765 000120 00000004037 11316340273 021212 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 35; use Test::Mock::LWP; use DateTime; $LWP::UserAgent::VERSION = '6'; $HTTP::Request::VERSION = '6'; use_ok('Net::Google::Code::Issue'); can_ok( 'Net::Google::Code::Issue', 'new' ); { no warnings 'once'; $Net::Google::Code::Issue::USE_HYBRID = 1; } my $issue = Net::Google::Code::Issue->new( project => 'net-google-code' ); isa_ok( $issue, 'Net::Google::Code::Issue' ); isa_ok( $issue, 'Net::Google::Code::Issue::Base' ); my @attrs = qw/ reported id reporter status owner summary description labels cc comments stars/; for my $attr (@attrs) { can_ok( $issue, $attr ); } for my $method (qw/create update updated load list load_comments/) { can_ok( $issue, $method ); } $Mock_ua->mock( get => sub { $Mock_response } ); $Mock_ua->mock( default_header => sub { } ); # to erase warning $Mock_response->mock( content => sub { local $/; open my $fh, '<', 't/google_api/data/issue_8.xml' or die $!; <$fh>; } ); my $n1 = Net::Google::Code::Issue->new( project => 'net-google-code', ); ($n1) = $n1->list(id =>8); my %hash = ( 'owner' => 'sunnavy', 'project' => 'net-google-code', 'description' => 'test the hack of file field', 'reporter' => 'sunnavy', 'reported' => '2009-02-20T08:46:06', 'labels' => ['Test-fine'], 'status' => 'Accepted', 'summary' => 'test attachment 8', 'id' => '8', 'stars' => 1, ); for my $k ( keys %hash ) { is_deeply( $n1->$k, $hash{$k}, "$k is loaded" ); } $Mock_response->mock( content => sub { local $/; open my $fh, '<', 't/google_api/data/issues.xml' or die $!; <$fh>; } ); $issue = Net::Google::Code::Issue->new( project => 'net-google-code', ); my @list = $issue->list; is( scalar @list, 21, 'list number' ); is( $list[0]->id, 1, '1st issue id' ); is( $list[1]->id, 2, '2nd issue id' ); is_deeply( $list[9]->labels, [ 'Type-Defect', 'Priority-Medium' ], '9th issue labels' ); Net-Google-Code-0.19/t/google_api/02-comment.t000644 000765 000120 00000003117 11316340273 021523 0ustar00sunnavyadmin000000 000000 use strict; use warnings; use Test::More tests => 20; use Test::Mock::LWP; $LWP::UserAgent::VERSION = '6'; $HTTP::Request::VERSION = '6'; use DateTime; use_ok('Net::Google::Code::Issue::Comment'); can_ok( 'Net::Google::Code::Issue::Comment', 'new' ); my $comment = Net::Google::Code::Issue::Comment->new( project => 'net-google-code', issue_id => 9, ); isa_ok( $comment, 'Net::Google::Code::Issue::Comment' ); isa_ok( $comment, 'Net::Google::Code::Issue::Base' ); my @attrs = qw/date sequence issue_id author content updates /; for my $attr (@attrs) { can_ok( $comment, $attr ); } for my $method (qw/list/) { can_ok( $comment, $method ); } $Mock_ua->mock( get => sub { $Mock_response } ); $Mock_ua->mock( default_header => sub { } ); # to erase warning $Mock_response->mock( content => sub { local $/; open my $fh, '<', 't/google_api/data/comments.xml' or die $!; <$fh>; } ); my @list = $comment->list; is( scalar @list, 9, 'list number' ); is( $list[0]->sequence, 1, '1st comment id' ); is( $list[1]->sequence, 2, '2nd comment id' ); my %hash = ( 'author' => 'sunnavy', 'updates' => { 'labels' => ['-Priority-Medium'] }, 'sequence' => '1', 'date' => '2009-05-12T09:29:18', ); for my $k ( keys %hash ) { is_deeply( scalar $list[0]->$k, $hash{$k}, "$k is loaded" ); } is_deeply( scalar $list[7]->{updates}, { 'labels' => [ 'Type-Defect', 'test-ok', '0.05' ] }, "updates is loaded" ); is_deeply( scalar $list[8]->{updates}, { 'cc' => 'sunnavy' }, "updates is loaded" ); Net-Google-Code-0.19/t/google_api/data/000755 000765 000120 00000000000 11366126703 020371 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/t/google_api/data/comments.xml000644 000765 000120 00000016225 11316340273 022741 0ustar00sunnavyadmin000000 000000 http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full2009-10-13T04:22:25.994ZProjectHosting1http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/12009-05-12T09:29:18.000Z2009-05-12T09:29:18.000Z2009-05-12T09:29:18.000ZComment 1 by sunnavysunnavy/u/sunnavy/-Priority-Mediumhttp://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/22009-05-12T09:30:47.000Z2009-05-12T09:30:47.000Z2009-05-12T09:30:47.000ZComment 2 by sunnavysunnavy/u/sunnavy/http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/32009-05-13T05:14:15.000Z2009-05-13T05:14:15.000Z2009-05-13T05:14:15.000ZComment 3 by sunnavysunnavy/u/sunnavy/http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/42009-05-13T05:37:13.000Z2009-05-13T05:37:13.000Z2009-05-13T05:37:13.000ZComment 4 by sunnavysunnavy/u/sunnavy/http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/52009-05-13T05:40:51.000Z2009-05-13T05:40:51.000Z2009-05-13T05:40:51.000ZComment 5 by sunnavysunnavy/u/sunnavy/http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/62009-05-14T03:39:12.000Z2009-05-14T03:39:12.000Z2009-05-14T03:39:12.000ZComment 6 by sunnavysunnavy/u/sunnavy/test filesThu May 14 11:39:06 2009http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/72009-05-15T03:56:04.000Z2009-05-15T03:56:04.000Z2009-05-15T03:56:04.000ZComment 7 by sunnavysunnavy/u/sunnavy/OpSys-Allhttp://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/82009-05-15T14:36:43.000Z2009-05-15T14:36:43.000Z2009-05-15T14:36:43.000ZComment 8 by sunnavysunnavy/u/sunnavy/Type-Defecttest-ok0.05http://code.google.com/feeds/issues/p/net-google-code/issues/9/comments/full/92009-05-15T14:43:14.000Z2009-05-15T14:43:14.000Z2009-05-15T14:43:14.000ZComment 9 by sunnavysunnavy/u/sunnavy/sunnavyNet-Google-Code-0.19/t/google_api/data/issue_8.html000644 000765 000120 00000036665 11316340273 022651 0ustar00sunnavyadmin000000 000000 Issue 8 - net-google-code - issue 8 - Project Hosting on Google Code
Project Logo
Project Home
  
Downloads
  
Wiki
  
Issues
  
Source
    
New issue | Search
for
| Advanced search | Search tips
Issue 8: issue 8
1 person starred this issue and may be notified of changes. Back to list
Status:  Accepted
Owner:  sunnavy
Cc:  sunnavy, t...@example.com
Test-fine


Sign in to add a comment
 
Reported by sunnavy, Feb 20, 2009 
test the hack of file field
/tmp/aaa
223 bytes Download
/tmp/xx.pdf
6.1 KB Download
Comment 1 by sunnavy, Oct 12 (45 hours ago) 
(No comment was entered for this change.)
Summary: test attachment 8
Comment 2 by sunnavy, Oct 13 (43 hours ago) 
(No comment was entered for this change.)
Cc: sunnavy
Comment 3 by sunnavy, Oct 13 (43 hours ago) 
(No comment was entered for this change.)
Cc: t...@example.com
Comment 4 by sunnavy, Today (15 hours ago) 
comment with published hybrid version
Summary: issue 8
Sign in to add a comment

Hosted by Google Code
Net-Google-Code-0.19/t/google_api/data/issue_8.xml000644 000765 000120 00000003636 11316340273 022475 0ustar00sunnavyadmin000000 000000 http://code.google.com/feeds/issues/p/net-google-code/issues/full2009-10-13T05:34:27.802ZProjectHosting125http://code.google.com/feeds/issues/p/net-google-code/issues/full/82009-02-20T08:46:06.000Z2009-10-13T05:33:23.000Z2009-10-13T05:33:23.000Ztest attachment 8test the hack of file fieldsunnavy/u/sunnavy/Test-fine/u/sunnavy/sunnavy1openAcceptedNet-Google-Code-0.19/t/google_api/data/issues.xml000644 000765 000120 00000102514 11316340273 022424 0ustar00sunnavyadmin000000 000000 http://code.google.com/feeds/issues/p/net-google-code/issues/full2009-10-13T04:36:37.636ZProjectHosting125http://code.google.com/feeds/issues/p/net-google-code/issues/full/12009-01-06T04:35:54.000Z2009-01-06T04:36:46.000Z2009-01-06T04:36:46.000Ztest<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-High/u/sunnavy/sunnavy0closedVerifiedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/22009-01-07T03:17:39.000Z2009-02-20T08:38:13.000Z2009-02-20T08:38:13.000Zlabels<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> <b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> this is the end. sunnavy/u/sunnavy/Test-fine/u/sunnavy/sunnavy0openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/42009-02-10T11:46:45.000Z2009-02-10T11:46:45.000Z2009-02-10T11:46:45.000Ztest the result page<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/52009-02-10T12:12:47.000Z2009-02-10T12:12:47.000Z2009-02-10T12:12:47.000Zlabels<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectLabel-test/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/62009-02-10T12:15:20.000Z2009-02-10T12:15:20.000Z2009-02-10T12:15:20.000Zlabelstest testsunnavy/u/sunnavy/Type-DefectTest-self/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/72009-02-10T12:18:48.000Z2009-02-10T12:18:48.000Z2009-02-10T12:18:48.000Zlabelstest testsunnavy/u/sunnavy/Type-DefectTest-self/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/82009-02-20T08:46:06.000Z2009-02-20T08:46:06.000Z2009-02-20T08:46:06.000Ztest attachmenttest the hack of file fieldsunnavy/u/sunnavy/Test-fine/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/92009-05-12T09:27:31.000Z2009-05-15T14:43:14.000Z2009-05-15T14:43:14.000Ztest filesThu May 14 11:39:06 2009<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy//u/sunnavy/sunnavyOpSys-AllType-Defecttest-ok0.05/u/sunnavy/sunnavy0openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/102009-05-15T05:33:20.000Z2009-06-02T00:33:34.000Z2009-06-02T00:33:34.000Znot touch labelsthis is description sunnavy/u/sunnavy//u/sunnavy/sunnavy0.05test-okType-Defectblabla/u/sunnavy/sunnavy1openNewhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/112009-05-26T14:32:57.000Z2009-05-26T14:32:57.000Z2009-05-26T14:32:57.000ZEnter one-line summary<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/122009-05-26T14:35:18.000Z2009-05-26T14:35:18.000Z2009-05-26T14:35:18.000ZEnter one-line summary<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy0openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/132009-05-26T14:38:13.000Z2009-05-26T14:38:13.000Z2009-05-26T14:38:13.000ZEnter one-line summary<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy0openAcceptedhttp://code.google.com/feeds/issues/p/net-google-code/issues/full/142009-05-26T14:49:21.000Z2009-06-03T11:32:10.000Z2009-06-03T11:32:10.000Zsd1rtsunnavy/u/sunnavy/ok3/u/sunnavy/sunnavy0closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/152009-05-26T14:52:03.000Z2009-05-26T14:52:03.000Z2009-05-26T14:52:03.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy0closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/162009-05-26T14:54:57.000Z2009-05-26T14:54:57.000Z2009-05-26T14:54:57.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/172009-05-26T14:55:06.000Z2009-05-26T14:55:06.000Z2009-05-26T14:55:06.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/182009-05-26T14:56:56.000Z2009-05-26T14:56:56.000Z2009-05-26T14:56:56.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/192009-05-26T14:57:03.000Z2009-05-26T14:57:03.000Z2009-05-26T14:57:03.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/202009-05-26T14:57:09.000Z2009-05-26T14:57:09.000Z2009-05-26T14:57:09.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/212009-05-26T14:57:16.000Z2009-05-26T14:57:16.000Z2009-05-26T14:57:16.000Ztest sd push<b>What steps will reproduce the problem?</b> <b>1.</b> <b>2.</b> <b>3.</b> <b>What is the expected output? What do you see instead?</b> <b>Please use labels and text to provide additional information.</b> sunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1closedDuplicatehttp://code.google.com/feeds/issues/p/net-google-code/issues/full/222009-06-12T05:55:06.000Z2009-06-12T05:55:06.000Z2009-06-12T05:55:06.000Zfor sd testthis is descriptionsunnavy/u/sunnavy/Type-DefectPriority-Medium/u/sunnavy/sunnavy1openAcceptedNet-Google-Code-0.19/lib/Net/000755 000765 000120 00000000000 11366126703 016404 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/000755 000765 000120 00000000000 11366126703 017620 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/Code/000755 000765 000120 00000000000 11366126703 020472 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/Code.pm000644 000765 000024 00000017241 11365163204 021047 0ustar00sunnavystaff000000 000000 package Net::Google::Code; use Any::Moose; with 'Net::Google::Code::TypicalRoles'; use Scalar::Util qw/blessed/; our $VERSION = '0.19'; has 'project' => ( isa => 'Str', is => 'rw', ); has 'labels' => ( isa => 'ArrayRef', is => 'rw', ); has 'owners' => ( isa => 'ArrayRef', is => 'rw', ); has 'members' => ( isa => 'ArrayRef', is => 'rw', ); has 'summary' => ( isa => 'Str', is => 'rw', ); has 'description' => ( isa => 'Str', is => 'rw', ); has 'issues' => ( isa => 'ArrayRef[Net::Google::Code::Issue]', is => 'rw', ); has 'downloads' => ( isa => 'ArrayRef[Net::Google::Code::Download]', is => 'rw', ); has 'wikis' => ( isa => 'ArrayRef[Net::Google::Code::Wiki]', is => 'rw', ); sub download { my $self = shift; require Net::Google::Code::Download; return Net::Google::Code::Download->new( project => $self->project, $self->email ? ( email => $self->email ) : (), $self->password ? ( password => $self->password ) : (), @_ ); } sub issue { my $self = shift; require Net::Google::Code::Issue; return Net::Google::Code::Issue->new( project => $self->project, $self->email ? ( email => $self->email ) : (), $self->password ? ( password => $self->password ) : (), @_ ); } sub wiki { my $self = shift; require Net::Google::Code::Wiki; return Net::Google::Code::Wiki->new( project => $self->project, $self->email ? ( email => $self->email ) : (), $self->password ? ( password => $self->password ) : (), @_ ); } sub load { my $self = shift; my $content = $self->fetch( $self->base_url ); return $self->parse( $content ); } sub parse { my $self = shift; my $tree = shift; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my $summary = $tree->look_down( id => 'psum' )->find_by_tag_name('a')->content_array_ref->[0]; $self->summary($summary) if $summary; my $description = $tree->look_down( id => 'wikicontent' )->content_array_ref->[0]->as_text; $self->description($description) if $description; if ( my $members_header = $tree->look_down( _tag => 'b', sub { $_[0]->as_text eq 'Committers:' } ) ) { my @a = $members_header->parent->find_by_tag_name('a'); my @members; for my $member (@a) { push @members, $member->as_text; } $self->members( \@members ); } if ( my $owners_header = $tree->look_down( _tag => 'b', sub { $_[0]->as_text eq 'Owners:' } ) ) { my @a = $owners_header->parent->find_by_tag_name('a'); my @owners; for my $owner (@a) { push @owners, $owner->as_text; } $self->owners( \@owners ); } my @labels; my @labels_tags = $tree->look_down( href => qr/q\=label\:/ ); for my $tag (@labels_tags) { push @labels, $tag->content_array_ref->[0]; } $self->labels( \@labels ) if @labels; $tree->delete if $need_delete; return 1; } sub load_downloads { my $self = shift; my $content = $self->fetch( $self->base_feeds_url . 'downloads/list' ); my @rows = $self->rows( html => $content ); my @downloads; require Net::Google::Code::Download; for my $row ( @rows ) { my $download = Net::Google::Code::Download->new( project => $self->project, %$row, ); $download->load; push @downloads, $download; } $self->downloads( \@downloads ); } sub load_wikis { my $self = shift; my $wiki_svn = $self->base_svn_url . 'wiki/'; my $content = $self->fetch( $wiki_svn ); my $tree = $self->html_tree( html => $content ); my @wikis; my @li = $tree->find_by_tag_name('li'); for my $li ( @li ) { my $name = $li->as_text; if ( $name =~ /(\S+)\.wiki$/ ) { $name = $1; require Net::Google::Code::Wiki; my $wiki = Net::Google::Code::Wiki->new( project => $self->project, name => $name, ); $wiki->load; push @wikis, $wiki; } } $tree->delete; $self->wikis( \@wikis ); } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code - a simple client library for google code =head1 SYNOPSIS use Net::Google::Code; my $project = Net::Google::Code->new( project => 'net-google-code' ); $project->load; # load its metadata, e.g. summary, owners, members, etc. print join(', ', @{ $project->owners } ); # return a Net::Google::Code::Issue object, of which the id is 30 $project->issue( id => 30 ); # return a Net::Google::Code::Download object, of which the file name is # 'FooBar-0.01.tar.gz' $project->download( name => 'FooBar-0.01.tar.gz' ); # return a Net::Google::Code::Wiki object, of which the page name is 'Test' $project->wiki( name => 'Test' ); # loads all the downloads $project->load_downloads; my $downloads = $project->downloads; # loads all the wikis $project->load_wikis; my $wikis = $project->wikis; =head1 DESCRIPTION Net::Google::Code is a simple client library for projects hosted in Google Code. Since 0.15, Net::Google::Code offers google's official issues api support. Besides the new C, C and methods, which use the api from start, you can set C<$Net::Google::Code::Issue::USE_HYBRID> to true to load, create and update issue with the api too. But the official api is not function complete yet( e.g. no attachment support, can't merge, etc. ), Net::Google::Code will back to the scraping way to accomplish those stuff. =head1 ATTRIBUTES =over 4 =item project the project name =item email, password user's email and password, used to authenticate =item base_url the project homepage =item base_svn_url the project svn url (without trunk) =item base_feeds_url the project feeds url =item summary =item description =item labels =item owners =item members =back =head1 INTERFACE =over 4 =item load load project's home page, and parse its metadata =item parse acturally do the parse job, for load(); =item load_downloads load all the downloads, and store them as an arrayref in $self->downloads =item load_wikis load all the wikis, and store them as an arrayref in $self->wikis =item issue return a new L object, arguments will be passed to L's new method. =item download return a new L object, arguments will be passed to L's new method. =item wiki return a new L object, arguments will be passed to L's new method. =back =head1 DEPENDENCIES L, L, L, L L, L, L, L, L, L =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. This project is very very young, and api is not stable yet, so don't use this in production, at least for now. =head1 AUTHOR sunnavy C<< >> Fayland Lam C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/AtomParser.pm000644 000765 000120 00000004236 11330470234 023102 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::AtomParser; use strict; use warnings; use Params::Validate ':all'; use HTML::Entities; sub new { my $class = shift; bless \(my $a), $class; } sub parse { my $self = shift; my ($content) = validate_pos( @_, 1 ); my $feed = {}; my $entries = []; if ( $content =~ /(.*?)/s ) { my $feed_info = $1; while ( $feed_info =~ m{<(?!link)(\w+).*?>(.*)}sg ) { $feed->{$1} = decode_entities($2); } } while ( $content =~ m{(.*?)}sg ) { my $entry_info = $1; my $entry = {}; while ( $entry_info =~ m{<(?!link)(\w+).*?>(.*)}sg ) { my $value = $2; $value =~ s!\s*<(\w+)>(.*?)\s*!$2!g; $entry->{$1} = decode_entities($value); } push @$entries, $entry; } return ( $feed, $entries ); } 1; __END__ =head1 NAME Net::Google::Code::AtomParser - AtomParser with a parsing method for gcode =head1 DESCRIPTION =head1 INTERFACE =head2 new =head2 parse( $xml_content ) return( $feed, $entries ), $feed is a hashref like { 'title' => 'Issue updates for project net-google-code on Google Code', 'id' => 'http://code.google.com/feeds/p/net-google-code/issueupdates/basic', 'updated' => '2009-06-12T05:55:48Z' } $entries is an arrayref like [ { 'content' => '
second comment
', 'name' => 'sunnavy', 'title' => 'Update 2 to issue 22 ("for sd test")', 'id' => 'http://code.google.com/feeds/p/net-google-code/issueupdates/basic/22/2', 'updated' => '2009-06-12T05:55:48Z' }, { 'content' => '
first comment
', 'name' => 'sunnavy', 'title' => 'Update 1 to issue 22 ("for sd test")', 'id' => 'http://code.google.com/feeds/p/net-google-code/issueupdates/basic/22/1', 'updated' => '2009-06-12T05:55:22Z' }, ] =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/DateTime.pm000644 000765 000120 00000003342 11330470234 022516 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::DateTime; use Any::Moose; extends 'DateTime'; our %MONMAP = ( Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6, Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12, ); sub new_from_string { my $class = shift; my $base_date = shift; if ( $base_date =~ /\w{3}\s+(\w+)\s+(\d+)\s+(\d\d):(\d\d):(\d\d)\s+(\d{4})/ ) { # Tue Jan 6 19:17:39 2009 my $mon = $1; my $dom = $2; my $h = $3; my $m = $4; my $s = $5; my $y = $6; my $date = $class->new( year => $y, month => $MONMAP{$mon}, day => $dom, hour => $h, minute => $m, second => $s, time_zone => 'US/Pacific', # google's time zone ); $date->set_time_zone( 'UTC' ); return $date; } elsif ( $base_date =~ /(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})Z/ ) { # 2009-06-01T13:00:10Z return $class->new( year => $1, month => $2, day => $3, hour => $4, minute => $5, second => $6, time_zone => 'UTC', ); } } no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::DateTime - DateTime with a parsing method for gcode =head1 DESCRIPTION =head1 INTERFACE =head2 new_from_string =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Download.pm000644 000765 000120 00000010067 11357074015 022601 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Download; use Any::Moose; use Params::Validate qw(:all); use Scalar::Util qw/blessed/; with 'Net::Google::Code::TypicalRoles'; has 'project' => ( isa => 'Str', is => 'rw', ); has 'name' => ( isa => 'Str', is => 'rw', ); has 'size' => ( isa => 'Str', is => 'rw', ); has 'download_url' => ( isa => 'Str', is => 'rw', ); has 'count' => ( isa => 'Int', is => 'rw', ); has 'labels' => ( isa => 'ArrayRef[Str]', is => 'rw', ); has 'checksum' => ( isa => 'Str', is => 'rw', ); has 'uploaded_by' => ( isa => 'Str', is => 'rw', ); has 'uploaded' => ( isa => 'Str', is => 'rw', ); sub load { my $self = shift; my $name = shift || $self->name; die "current object doesn't have name and load() is not passed a name either" unless $name; # http://code.google.com/p/net-google-code/downloads/detail?name=Net-Google-Code-0.01.tar.gz my $content = $self->fetch( $self->base_url . "downloads/detail?name=$name" ); $self->name( $name ) unless $self->name && $self->name eq $name; return $self->parse( $content ); } sub parse { my $self = shift; my $tree = shift; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my $entry; my $uploaded = $tree->look_down(class => 'date')->attr('title'); $self->uploaded( $uploaded ) if $uploaded; my @labels_tag = $tree->look_down( class => 'label' ); my @labels; for my $tag ( @labels_tag ) { push @labels, $tag->as_text; } $self->labels( \@labels ); # parse uploaded_by and download count. # uploaded and labels are kind of special, so they're handleed above my ($meta) = $tree->look_down( id => 'issuemeta' ); my @meta = $meta->find_by_tag_name('tr'); for my $meta (@meta) { my ( $key, $value ); $key = $meta->find_by_tag_name('th'); next unless $key; $key = $key->as_text; my $td = $meta->find_by_tag_name('td'); next unless $td; $value = $td->as_text; if ( $key =~ /Uploaded.*?by/ ) { $self->uploaded_by($value); } elsif ( $key =~ /Downloads/ ) { $self->count($value); } } # download_url and size my $desc = $tree->look_down( class => 'vt issuedescription' ); my $box_inner = $desc->look_down( class => 'box-inner' ); $self->download_url( $box_inner->content_array_ref->[0]->attr('href') ); my $size = $box_inner->content_array_ref->[3]; $size =~ s/^\D+//; $size =~ s/\s+$//; $self->size( $size ) if $size; # checksum my $span = $desc->find_by_tag_name('span'); my $checksum = $span->content_array_ref->[0]; if ( $checksum =~ /^SHA1 Checksum:\s+(\w+)/ ) { $self->checksum( $1 ); } $tree->delete if $need_delete; } sub BUILDARGS { my $class = shift; my %args; if ( @_ % 2 && ref $_[0] eq 'HASH' ) { %args = %{$_[0]}; } else { %args = @_; } my %translations = ( filename => 'name', 'downloadcount' => 'count' ); for my $key ( keys %translations ) { if ( exists $args{$key} ) { $args{ $translations{$key} } = $args{$key}; } } return $class->SUPER::BUILDARGS(%args); } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Download - Google Code Download =head1 SYNOPSIS use Net::Google::Code::Download; my $issue = Net::Google::Code::Download->new( project => 'net-google-code' ); $issue->load( 'Net-Google-Code-0.01.tar.gz' ); =head1 DESCRIPTION =head1 INTERFACE =over 4 =item load =item parse =item project =item name =item size =item download_url =item count =item labels =item checksum =item uploaded_by =item uploaded =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/000755 000765 000120 00000000000 11366126703 021562 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/Code/Issue.pm000644 000765 000120 00000047477 11365734373 022152 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Issue; use Any::Moose; use Params::Validate qw(:all); with 'Net::Google::Code::TypicalRoles'; use Net::Google::Code::DateTime; use Net::Google::Code::Issue::Comment; use Net::Google::Code::Issue::Attachment; use Scalar::Util qw/blessed/; use Net::Google::Code::Issue::Util; extends 'Net::Google::Code::Issue::Base'; # set this to true to enable hybrid load, create and update our $USE_HYBRID; use XML::FeedPP; has 'id' => ( isa => 'Int', is => 'rw', ); has 'status' => ( isa => 'Str', is => 'rw', ); has 'owner' => ( isa => 'Str', is => 'rw', ); has 'cc' => ( isa => 'Str', is => 'rw', ); has 'summary' => ( isa => 'Str', is => 'rw', ); has 'reporter' => ( isa => 'Str', is => 'rw', ); has 'reported' => ( isa => 'DateTime', is => 'rw', ); has 'merged' => ( isa => 'Int', is => 'rw', ); has 'stars' => ( isa => 'Int', is => 'rw', ); has 'closed' => ( isa => 'Str', is => 'rw', ); has 'description' => ( isa => 'Str', is => 'rw', ); has 'labels' => ( isa => 'ArrayRef', is => 'rw', default => sub { [] }, ); has 'comments' => ( isa => 'ArrayRef[Net::Google::Code::Issue::Comment]', is => 'rw', default => sub { [] }, ); has 'attachments' => ( isa => 'ArrayRef[Net::Google::Code::Issue::Attachment]', is => 'rw', default => sub { [] }, ); sub load { my $self = shift; my $id = shift || $self->id; die "current object doesn't have id and load() is not passed an id either" unless $id; if ($USE_HYBRID) { unless ( $self->{loaded_way} && $self->{loaded_way} eq 'api' && $id == $self->id ) { my ($issue) = $self->list( id => $id ); %$self = %$issue; } $self->{loaded_way} = 'hybrid'; $self->load_comments; # here we do scraping to get stuff not can be seen from feeds my $content = $self->fetch( $self->base_url . "issues/detail?id=" . $id ); return $self->parse_hybrid($content); } else { my $content = $self->fetch( $self->base_url . "issues/detail?id=" . $id ); $self->id( $id ); $self->{loaded_way} = 'scraping'; return $self->parse($content); } } sub parse { my $self = shift; my $tree = shift; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; # extract summary my ($summary) = $tree->look_down( class => 'h3' ); $self->summary( $summary->as_text ); # extract reporter, reported and description my $description = $tree->look_down( class => 'vt issuedescription' ); my $author_tag = $description->look_down( class => "author" ); $self->reporter( $author_tag->content_array_ref->[1]->as_text ); $self->reported( Net::Google::Code::DateTime->new_from_string($author_tag->look_down( class => 'date' )->attr('title') )); my $text = $description->find_by_tag_name('pre')->as_text; $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\r\n/\n/g; $self->description( $text ); my $att_tag = $description->look_down( class => 'attachments' ); my @attachments; @attachments = Net::Google::Code::Issue::Attachment->parse_attachments($att_tag) if $att_tag; $self->attachments( \@attachments ); my ($meta) = $tree->look_down( id => 'issuemeta' ); { # let's find stars my ($header) = $tree->look_down( id => 'issueheader' ); if ( $header && $header->as_text =~ /(\d+) \w+ starred this issue/ ) { # the \w+ is person or people, I don't know if google will change that word # some time, so just use \w+ my $stars = $1; $self->stars($stars); } } my @meta = $meta->find_by_tag_name('tr'); my @labels; for my $meta (@meta) { my ( $key, $value ); if ( my $k = $meta->find_by_tag_name('th') ) { my $v = $meta->find_by_tag_name('td'); my $k_content = $k->content_array_ref->[0]; while ( ref $k_content ) { $k_content = $k_content->content_array_ref->[0]; } $key = $k_content; # $key is like 'Status:#' $key =~ s/:.$//; # s/:#$// doesn't work, no idea why $key = lc $key; if ($v) { $value = $v->as_text; $value =~ s/^\s+//; $value =~ s/\s+$//; } if ( $self->can( $key ) ) { if ( $key eq 'merged' && $value =~ /issue\s+(\d+)/ ) { $value = $1; } $self->$key( $value ); } else { warn "no idea where to keep $key"; } } else { my $href = $meta->look_down( class => 'label' )->attr('href'); if ( $href =~ /list\?q=label:(.+)/ ) { push @labels, $1; } } } $self->labels( \@labels ); # extract comments my @comments_tag = $tree->look_down( class => 'vt issuecomment' ); my @comments; for my $tag (@comments_tag) { next unless $tag->look_down( class => 'author' ); my $comment = Net::Google::Code::Issue::Comment->new( project => $self->project ); $comment->parse($tag); push @comments, $comment; } my $initial_comment = Net::Google::Code::Issue::Comment->new( project => $self->project, sequence => 0, date => $self->reported, author => $self->reporter, content => $self->description, attachments => $self->attachments, ); my @initial_labels = @{$self->labels}; my %meta = map { $_ => 1 } qw/summary status cc owner/; for my $c ( reverse @comments ) { my $updates = $c->updates; for ( keys %meta ) { # once these changes, we can't know the inital value delete $meta{$_} if exists $updates->{$_}; } if ( $updates->{labels} ) { my @labels = @{$updates->{labels}}; for my $label (@labels) { if ( $label =~ /^-(.*)$/ ) { unshift @initial_labels, $1; } else { @initial_labels = grep { $_ ne $label } @initial_labels; } } } } $initial_comment->updates->{labels} = \@initial_labels; for ( keys %meta ) { $initial_comment->updates->{$_} = $self->$_; } unshift @comments, $initial_comment; $self->comments( \@comments ); $tree->delete if $need_delete; return 1; } sub load_comments { my $self = shift; require Net::Google::Code::Issue::Comment; my $comment = Net::Google::Code::Issue::Comment->new( issue_id => $self->id, map { $_ => $self->$_ } grep { $self->$_ } qw/project email password token/ ); # $comment is for initial comment we will work out $self->comments( [ $comment, $comment->list ] ); } sub parse_hybrid { my $self = shift; my $tree = shift; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my $description = $tree->look_down( class => 'vt issuedescription' ); my $att_tag = $description->look_down( class => 'attachments' ); my @attachments; @attachments = Net::Google::Code::Issue::Attachment->parse_attachments($att_tag) if $att_tag; $self->attachments( \@attachments ); my ($meta) = $tree->look_down( id => 'issuemeta' ); my @meta = $meta->find_by_tag_name('tr'); my @labels; for my $meta (@meta) { my ( $key, $value ); if ( my $k = $meta->find_by_tag_name('th') ) { my $v = $meta->find_by_tag_name('td'); my $k_content = $k->content_array_ref->[0]; while ( ref $k_content ) { $k_content = $k_content->content_array_ref->[0]; } $key = $k_content; # $key is like 'Status:#' $key =~ s/:.$//; # s/:#$// doesn't work, no idea why $key = lc $key; if ($v) { $value = $v->as_text; $value =~ s/^\s+//; $value =~ s/\s+$//; } if ( $self->can( $key ) ) { if ( $key eq 'merged' && $value =~ /issue\s+(\d+)/ ) { $value = $1; } $self->$key( $value ); } else { warn "no idea where to keep $key"; } } } # extract comments my @comments_tag = $tree->look_down( class => 'vt issuecomment' ); ( undef, my @comments ) = @{$self->comments}; my $number = 1; # 0 is for initial comment for my $tag (@comments_tag) { next unless $tag->look_down( class => 'author' ); my $comment = $self->comments->[$number++]; $comment->parse_hybrid($tag); } my $initial_comment = Net::Google::Code::Issue::Comment->new( sequence => 0, date => $self->reported, author => $self->reporter, content => $self->description, attachments => $self->attachments, issue_id => $self->id, map { $_ => $self->$_ } grep { $self->$_ } qw/project email password token/ ); my @initial_labels = @{$self->labels}; my %meta = map { $_ => 1 } qw/summary status cc owner/; for my $c ( reverse @comments ) { my $updates = $c->updates; for ( keys %meta ) { # once these changes, we can't know the inital value delete $meta{$_} if exists $updates->{$_}; } if ( $updates->{labels} ) { my @labels = @{$updates->{labels}}; for my $label (@labels) { if ( $label =~ /^-(.*)$/ ) { unshift @initial_labels, $1; } else { @initial_labels = grep { $_ ne $label } @initial_labels; } } } } $initial_comment->updates->{labels} = \@initial_labels; for ( keys %meta ) { $initial_comment->updates->{$_} = $self->$_; } $self->comments->[0] = $initial_comment; $tree->delete if $need_delete; return 1; } sub _load_from_xml { my $self = shift; my $ref = Net::Google::Code::Issue::Util->translate_from_xml( shift, type => 'issue' ); for my $k ( keys %$ref ) { if ( $self->can($k) ) { $self->{$k} = $ref->{$k}; } } return $self; } sub create { my $self = shift; my %args = validate( @_, { labels => { type => ARRAYREF, optional => 1 }, files => { type => ARRAYREF, optional => 1 }, map { $_ => { type => SCALAR, optional => 1 } } qw/comment summary status owner cc/, } ); if ( $args{files} || !$USE_HYBRID) { $self->sign_in; $self->fetch( $self->base_url . 'issues/entry' ); if ( $args{files} ) { # hack hack hack # manually add file fields since we don't have them in page. my $html = $self->mech->content; for ( 1 .. @{ $args{files} } ) { $html =~ s{(?<=id="attachmentareadeventry">)}{}; } $self->mech->update_html($html); } $self->mech->form_with_fields( 'comment', 'summary' ); # leave labels alone unless there're labels. $self->mech->field( 'label', $args{labels} ) if $args{labels}; if ( $args{files} ) { for ( my $i = 0 ; $i < scalar @{ $args{files} } ; $i++ ) { $self->mech->field( 'file' . ( $i + 1 ), $args{files}[$i] ); } } $self->mech->submit_form( fields => { map { $_ => $args{$_} } grep { exists $args{$_} } qw/comment summary status owner cc/ } ); my ( $contains, $id ) = $self->html_tree_contains( html => $self->mech->content, look_down => [ class => 'notice' ], as_text => qr/Issue\s+(\d+)/i, ); if ($contains) { $self->load($id); return $id; } else { warn 'create issue failed'; return; } } else { # we can use google's official api here my $author = $self->email; $author =~ s/@.*//; my %args = ( author => $author, @_ ); my $xml = Net::Google::Code::Issue::Util->translate_to_xml( \%args, type => 'create' ); my $ua = $self->ua; my $url = $self->feeds_issues_url . '/full'; my $request = HTTP::Request->new( 'POST', $url, undef, $xml ); my $res = $ua->request($request); if ( $res->is_success ) { my $content = $res->content; # let's fake wrap the entry with $content =~ s!}; my $feed = XML::FeedPP->new($content); my ($item) = $feed->get_item; $self->_load_from_xml($item); $self->load( $self->id ); return 1; } else { die "try to POST $url failed: " . $res->status_line . "\n" . $res->content; } } } sub update { my $self = shift; my %args = validate( @_, { labels => { type => ARRAYREF, optional => 1 }, files => { type => ARRAYREF, optional => 1 }, map { $_ => { type => SCALAR, optional => 1 } } qw/comment summary status owner merge_into cc blocked_on/, } ); if ( $args{files} || $args{merge_into} || $args{blocked_on} || !$USE_HYBRID ) { $self->sign_in; $self->fetch( $self->base_url . 'issues/detail?id=' . $self->id ); if ( $args{files} ) { # hack hack hack # manually add file fields since we don't have them in page. my $html = $self->mech->content; for ( 1 .. @{ $args{files} } ) { $html =~ s{(?<=id="attachmentarea">)}{}; } $self->mech->update_html($html); } $self->mech->form_with_fields( 'comment', 'summary' ); # leave labels alone unless there're labels. $self->mech->field( 'label', $args{labels} ) if $args{labels}; if ( $args{files} ) { for ( my $i = 0 ; $i < scalar @{ $args{files} } ; $i++ ) { $self->mech->field( 'file' . ( $i + 1 ), $args{files}[$i] ); } } $self->mech->submit_form( fields => { map { $_ => $args{$_} } grep { exists $args{$_} } qw/comment summary status owner merge_into cc blocked_on/ } ); if ( $self->html_tree_contains( html => $self->mech->content, look_down => [ class => 'notice' ], as_text => qr/has been updated/, ) ) { $self->load( $self->id ); # maybe this is too much? return 1; } else { warn 'update failed'; return; } } else { my $author = $self->email; $author =~ s/@.*//; my %args = ( author => $author, ( map { $_ => $self->$_ } qw/title content status owner cc labels/ ), @_, ); my $xml = Net::Google::Code::Issue::Util->translate_to_xml( \%args, type => 'update' ); my $ua = $self->ua; my $url = $self->feeds_issues_url . '/' . $self->id . '/comments/full'; my $request = HTTP::Request->new( 'POST', $url, undef, $xml ); my $res = $ua->request($request); if ( $res->is_success ) { $self->load( $self->id ); # let's reload return 1; } else { die "try to POST $url failed: " . $res->status_line . "\n" . $res->content; } } } sub updated { my $self = shift; my $last_comment = $self->comments->[-1]; return $last_comment ? $last_comment->date : undef; } sub list { my $self = shift; validate( @_, { q => { optional => 1, type => SCALAR }, can => { optional => 1, type => SCALAR }, author => { optional => 1, type => SCALAR }, id => { optional => 1, type => SCALAR }, label => { optional => 1, type => SCALAR }, max_results => { optional => 1, type => SCALAR }, owner => { optional => 1, type => SCALAR }, published_min => { optional => 1, type => SCALAR }, published_max => { optional => 1, type => SCALAR }, updated_min => { optional => 1, type => SCALAR }, updated_max => { optional => 1, type => SCALAR }, start_index => { optional => 1, type => SCALAR }, } ); my %args = @_; my $url = $self->feeds_issues_url . '/full?'; require URI::Escape; for my $k ( keys %args ) { next unless $args{$k}; my $v = $args{$k}; $k =~ s/_/-/g; $url .= "$k=" . URI::Escape::uri_escape($v) . '&'; } my $ua = $self->ua; my $res = $ua->get($url); if ( $res->is_success ) { my $feed = XML::FeedPP->new($res->content); my @items = $feed->get_item; my @list = map { my $t = Net::Google::Code::Issue->new( loaded_way => 'api', map { $_ => $self->$_ } grep { $self->$_ } qw/project email password token/ ); $t->_load_from_xml($_); } @items; return wantarray ? @list : \@list; } else { die "try to get $url failed: " . $res->status_line . "\n" . $res->content; } } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Issue - Google Code Issue =head1 SYNOPSIS use Net::Google::Code::Issue; my $issue = Net::Google::Code::Issue->new( project => 'net-google-code' ); $issue->load(42); =head1 DESCRIPTION =head1 ATTRIBUTES =over 4 =item project project name =item email, password user's email and password =item id =item status =item owner =item reporter =item reported =item merged =item stars =item closed =item cc =item summary =item description =item labels =item comments =item attachments =back =head1 INTERFACE =over 4 =item load =item parse =item updated the last comment's date. =item create comment, summary, status, owner, cc, labels, files. =item update comment, summary, status, owner, merge_into, cc, labels, blocked_on, files. =item list( q => '', can => '', author => '', id => '', label => '', max_results => '', owner => '', published_min => '', published_max => '', updated_min => '', updated_max => '', start_index => '' ) google's api way to get/search issues return a list of loaded issues in list context, a ref to the list otherwise. =item load_comments google's api way to get and load comments( no scraping is done here ) =item parse_hybrid when C<$USE_HYBRID> is true, we will try to load issue with the google's official api, but as the api is not complete, we still need to do scraping to load something( e.g. attachments ), this method is used to do this. =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/000755 000765 000120 00000000000 11366126703 021373 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/Code/TypicalRoles.pm000644 000765 000120 00000001447 11330470234 023440 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::TypicalRoles; use Any::Moose 'Role'; with 'Net::Google::Code::Role::Fetchable'; with 'Net::Google::Code::Role::URL'; with 'Net::Google::Code::Role::HTMLTree'; with 'Net::Google::Code::Role::Authentication'; with 'Net::Google::Code::Role::Pageable'; with 'Net::Google::Code::Role::Predefined'; no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::TypicalRoles - TypicalRoles =head1 DESCRIPTION this is an aggregation of roles that includes the typical roles for Code.pm, Code/Issue.pm, Code/Download.pm and Code/Wiki.pm =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Wiki/000755 000765 000120 00000000000 11366126703 021375 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/lib/Net/Google/Code/Wiki.pm000644 000765 000120 00000007011 11357072673 021740 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Wiki; use Any::Moose; use Params::Validate qw(:all); with 'Net::Google::Code::TypicalRoles'; has 'project' => ( isa => 'Str', is => 'rw', ); has 'name' => ( isa => 'Str', is => 'rw', ); has 'source' => ( isa => 'Str', is => 'rw', ); has 'content' => ( isa => 'Str', is => 'rw', ); has 'updated' => ( isa => 'Str', is => 'rw', ); has 'updated_by' => ( isa => 'Str', is => 'rw', ); has 'labels' => ( isa => 'ArrayRef[Str]', is => 'rw', ); has 'summary' => ( isa => 'Str', is => 'rw', ); has 'comments' => ( isa => 'ArrayRef[Net::Google::Code::Wiki::Comment]', is => 'rw', ); sub load_source { my $self = shift; die "current object doesn't have name" unless $self->name; my $source = $self->fetch( $self->base_svn_url . 'wiki/' . $self->name . '.wiki' ); $self->source($source); return $self->parse_source; } sub parse_source { my $self = shift; my @meta = grep { /^#/ } split /\n/, $self->source; for my $meta (@meta) { chomp $meta; if ( $meta =~ /summary\s+(.*)/ ) { $self->summary($1); } elsif ( $meta =~ /labels\s+(.*)/ ) { my @labels = split /,\s*/, $1; $self->labels( \@labels ); } } } sub load { my $self = shift; my $name = shift || $self->name; die "current object doesn't have name and load() is not passed a name either" unless $name; # http://code.google.com/p/net-google-code/wiki/TestPage my $content = $self->fetch( $self->base_url . 'wiki/' . $name ); $self->name($name) unless $self->name && $self->name eq $name; $self->load_source; return $self->parse($content); } sub parse { my $self = shift; my $tree = shift; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my $wiki = $tree->look_down( id => 'wikimaincol' ); my $updated = $wiki->find_by_tag_name('td')->find_by_tag_name('span')->attr('title'); my $updated_by = $wiki->find_by_tag_name('td')->find_by_tag_name('a')->as_text; $self->updated($updated) if $updated; $self->updated_by($updated_by) if $updated_by; $self->content( $tree->content_array_ref->[-1]->as_HTML ); my @comments = (); my @comments_element = $tree->look_down( class => 'artifactcomment' ); for my $element (@comments_element) { next unless $element->look_down( class => 'commentcontent' ); require Net::Google::Code::Wiki::Comment; my $comment = Net::Google::Code::Wiki::Comment->new; $comment->parse($element); push @comments, $comment; } $self->comments( \@comments ); $tree->delete; return 1; } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Wiki - Google Code Wiki =head1 SYNOPSIS use Net::Google::Code::Wiki; my $wiki = Net::Google::Code::Wiki->new( project => 'net-google-code', name => 'TestPage', ); $wiki->load; $wiki_entry->source; =head1 INTERFACE =over 4 =item load =item parse =item load_source =item parse_source =item project =item name =item source =item summary =item labels =item content =item updated_by =item updated =item comments =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Wiki/Comment.pm000644 000765 000120 00000002626 11357075375 023353 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Wiki::Comment; use Any::Moose; use Params::Validate qw(:all); with 'Net::Google::Code::Role::HTMLTree'; has 'content' => ( isa => 'Str', is => 'rw', ); has 'author' => ( isa => 'Str', is => 'rw', ); has 'date' => ( isa => 'Str', is => 'rw', ); sub parse { my $self = shift; my $element = shift; my $need_update = not blessed $element; $element = $self->html_tree( html => $element ) unless blessed $element; my $author = $element->look_down( class => 'author' )->find_by_tag_name('a')->as_text; my $date = $element->look_down( class => 'date' )->attr('title'); my $content = $element->look_down( class => 'commentcontent' )->as_text; $content =~ s/\s+$//; # remove trailing spaces $self->author( $author ) if $author; $self->date( $date ) if $date; $self->content( $content ) if $content; $element->delete if $need_update; return 1; } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Wiki::Comment - Google Code Wiki Comment =head1 INTERFACE =over 4 =item parse( HTML::Element or html segment string ) =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/Authentication.pm000644 000765 000120 00000003613 11330470234 024703 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::Authentication; use Any::Moose 'Role'; with 'Net::Google::Code::Role::Fetchable'; has 'email' => ( isa => 'Str', is => 'rw', ); has 'password' => ( isa => 'Str', is => 'rw', ); sub sign_in { my $self = shift; return 1 if $self->signed_in; die "need password" unless $self->password; $self->mech->get('https://www.google.com/accounts/Login'); $self->mech->submit_form( with_fields => { Email => $self->email, Passwd => $self->password, }, ); die 'sign in failed to google code' unless $self->signed_in; return 1; } sub sign_out { my $self = shift; $self->mech->get('https://www.google.com/accounts/Logout'); die 'sign out failed to google code' unless $self->signed_in; return 1; } sub signed_in { my $self = shift; my $html = $self->mech->content; return unless $html; # remove lines of head, style and script $html =~ s!.*?!!sg; $html =~ s!!!sg; $html =~ s!!!sg; my @lines = split /\n/, $html; my $signed_in; my $line = 0; # only check the first 30 lines or so in case user input of 'sign out' # exists below for ( @lines ) { $signed_in = 1 if /sign out/i; $line++; last if $line == 30; } return $signed_in; } no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::Role::Authentication - Authentication Role =head1 DESCRIPTION =head1 INTERFACE =head2 sign_in sign in =head2 sign_out sign out =head2 signed_in return 1 if already signed in, return undef elsewise. =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/Fetchable.pm000644 000765 000120 00000002562 11330470234 023603 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::Fetchable; use Any::Moose 'Role'; use Params::Validate ':all'; use WWW::Mechanize; our $MECH; sub mech { if (!$MECH) { $MECH = WWW::Mechanize->new( agent => 'Net-Google-Code', keep_alive => 4, cookie_jar => {}, stack_depth => 1, timeout => 60, ); } return $MECH ; } sub fetch { my $self = shift; my ($url) = validate_pos( @_, { type => SCALAR } ); $self->mech->get($url); if ( !$self->mech->response->is_success ) { die "Server threw an error " . $self->mech->response->status_line . " for " . $url; } else { my $content = $self->mech->content; # auto decode the content to erase HTML::Parser's utf8 warning like this: # Parsing of undecoded UTF-8 will give garbage when decoding entities utf8::downgrade( $content, 1 ); return $content; } } no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::Role::Fetchable - Fetchable Role =head1 DESCRIPTION =head1 INTERFACE =over 4 =item mech =item fetch =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/HTMLTree.pm000644 000765 000120 00000004255 11357075744 023333 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::HTMLTree; use Any::Moose 'Role'; use HTML::TreeBuilder; use Params::Validate qw(:all); use Scalar::Util qw/blessed/; sub html_tree { my $self = shift; my %args = validate( @_, { html => { type => SCALAR } } ); my $tree = HTML::TreeBuilder->new; $tree->parse_content($args{html}); $tree->elementify; return $tree; } sub html_tree_contains { my $self = shift; my %args = validate( @_, { html => { type => SCALAR }, look_down => { type => ARRAYREF, optional => 1 }, # SCALARREF is for the regex as_text => { type => SCALAR | SCALARREF }, } ); my $tree; my $need_delete; if ( blessed $args{html} ) { $tree = $args{html}; } else { $tree = $self->html_tree( html => $args{html} ); $need_delete = 1; } my $part = $tree; if ( $args{look_down} ) { ($part) = $tree->look_down( @{ $args{look_down} } ); } my $text = $part && $part->as_text; $tree->delete if $need_delete; return unless defined $text; return 1 if $text eq $args{as_text}; if ( ( ref $args{as_text} eq 'Regexp' ) && ( my @captures = $text =~ $args{as_text} ) ) { # note, if there's no captures at all but the string matches, # @captures will be set to (1), so don't use @captures unless you # know there's some capture in the regex return wantarray ? ( 1, @captures ) : 1; } return; } no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::Role::HTMLTree - HTMLTree Role =head1 DESCRIPTION =head1 INTERFACE =head2 html_tree return a new HTML::TreeBuilder object, with current content parsed =head2 html_tree_contains a help method to help test if the current content contains some stuff, args are: look_down => [ look_down's args ] as_text => qr/foo/ look_down is used to limit the area, as_text's value can be regex or string =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/Pageable.pm000644 000765 000120 00000011251 11357075774 023444 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::Pageable; use Any::Moose 'Role'; use Params::Validate ':all'; use WWW::Mechanize; with 'Net::Google::Code::Role::Fetchable'; with 'Net::Google::Code::Role::HTMLTree'; use Scalar::Util qw/blessed/; sub rows { my $self = shift; my %args = validate( @_, { html => { type => SCALAR | OBJECT }, limit => { type => SCALAR | UNDEF, optional => 1, }, } ); $args{limit} ||= 999_999_999; # the impossible huge limit my $tree = $args{html}; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; # assuming there's at most 20 columns my @titles; my $label_column; for my $num ( 0 .. 20 ) { my $title_tag = $tree->look_down( class => "col_$num" ); if ( $title_tag ) { my $title = $title_tag->as_text; if ( $title eq "\x{a0}" ) { $title_tag = ($tree->look_down( class => "col_$num" ))[1]; $title = $title_tag->as_text; } if ( $title =~ /(\w+)/ ) { push @titles, lc $1; if ( $title =~ /label/i ) { $label_column = $num; } } } else { last; } } die "no idea what the column spec is" unless @titles; my @rows; my $pagination = $tree->look_down( class => 'pagination' ); return unless $pagination; if ( $pagination->as_text =~ /\d+\s+-\s+\d+\s+of\s+\d+/ ) { # all the rows in a page push @rows, $self->_rows( html => $tree, titles => \@titles, label_column => $label_column, ); while ( scalar @rows < $args{limit} ) { my $next_link = $self->mech->find_link( text_regex => qr/Next\s+/ ); if ($next_link) { $self->mech->get( $next_link->url ); if ( $self->mech->response->is_success ) { push @rows, $self->_rows( html => $self->mech->content, titles => \@titles, label_column => $label_column, ); } else { die "failed to follow 'Next' link"; } } else { last; } } } $tree->delete if $need_delete; if ( scalar @rows > $args{limit} ) { # this happens when limit is less than the 1st page's number, so in # some similar situations return @rows[0 .. $args{limit}-1]; } else { return @rows; } } sub _rows { my $self = shift; my %args = validate( @_, { html => { type => SCALAR | OBJECT }, titles => { type => ARRAYREF, }, label_column => { optional => 1 }, } ); my $tree = $args{html}; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my @titles = @{$args{titles}}; my $label_column = $args{label_column}; my @columns; my @rows; for ( my $i = 0 ; $i < @titles ; $i++ ) { my @tags = $tree->look_down( class => qr/^vt (id )?col_$i/ ); my $k = 0; for ( my $j = 0 ; $j < @tags ; $j++ ) { my $column = $tags[$j]->as_text; next unless $column =~ /[-\w]/; # skip the '›' thing or alike my @elements = split /\x{a0}/, $column; for ( @elements ) { s/^\s+//; s/\s+$//; } $column = shift @elements; $column = '' if $column eq '----'; if ( $i == 0 ) { push @rows, { $titles[0] => $column }; } else { $rows[$k]{ $titles[$i] } = $column; } if ( $label_column && $i == $label_column ) { my @labels; if (@elements) { @labels = split /\s+/, shift @elements; } $rows[$k]{labels} = \@labels if @labels; } $k++; } } $tree->delete if $need_delete; return @rows; } no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::Role::Pageable - Pageable Role =head1 DESCRIPTION =head1 INTERFACE =over 4 =item rows =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/Predefined.pm000644 000765 000120 00000004072 11330470234 023771 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::Predefined; use Any::Moose 'Role'; use Params::Validate ':all'; use JSON; with 'Net::Google::Code::Role::Fetchable'; has 'predefined_status' => ( isa => 'HashRef', is => 'rw', ); has 'predefined_labels' => ( isa => 'ArrayRef', is => 'rw', ); no Any::Moose; sub load_predefined { my $self = shift; my $class = ref $self || $self; my $last_name; $last_name = lc $1 if $class =~ /::(\w+)$/; return unless $self->signed_in; my $base_url = $self->base_url; my $content = $self->fetch($self->base_url); if ( $content =~ /codesite_token\s*=\s*"(\w+)"/ ) { my $token = $1; my $mech = $self->mech; # I tried to use $mech->post( $url, token => $token ) # but without luck :( $mech->update_html(<<"EOF");
EOF $mech->submit_form( form_number => 1 ); die "failed to post to OptionsJSON page" unless $mech->success; my $js = $mech->content; my $object = from_json $js; return unless $object; $self->predefined_status( { open => [], closed => [] } ); for my $type (qw/open closed/) { for ( @{ $object->{$type} } ) { push @{ $self->predefined_status->{$type} }, $_->{name}; } } $self->predefined_labels( [] ); for ( @{ $object->{labels} } ) { push @{ $self->predefined_labels }, $_->{name}; } return 1; } else { warn "can't get user token"; return; } } 1; __END__ =head1 NAME Net::Google::Code::Role::Predefined - Predefined Role =head1 DESCRIPTION =head1 INTERFACE =over 4 =item load_predefined =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Role/URL.pm000644 000765 000120 00000001760 11330470234 022367 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Role::URL; use Any::Moose 'Role'; # requires don't support attribute yet :/ # requires 'project'; has 'base_url' => ( isa => 'Str', is => 'ro', lazy => 1, default => sub { 'http://code.google.com/p/' . $_[0]->project . '/' }, ); has 'base_svn_url' => ( is => 'ro', isa => 'Str', lazy => 1, default => sub { 'http://' . $_[0]->project . '.googlecode.com/svn/' }, ); has 'base_feeds_url' => ( is => 'ro', isa => 'Str', lazy => 1, default => sub { 'http://code.google.com/feeds/p/' . $_[0]->project . '/' }, ); no Any::Moose; 1; __END__ =head1 NAME Net::Google::Code::Role::URL - URL Role =head1 DESCRIPTION =head1 INTERFACE =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/Attachment.pm000644 000765 000120 00000011041 11357075213 024204 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Issue::Attachment; use Any::Moose; with 'Net::Google::Code::Role::Fetchable', 'Net::Google::Code::Role::HTMLTree'; use Scalar::Util qw/blessed/; use MIME::Types; use File::MMagic; has 'name' => ( isa => 'Str', is => 'rw' ); has 'url' => ( isa => 'Str', is => 'rw' ); has 'size' => ( isa => 'Str', is => 'rw' ); has 'id' => ( isa => 'Int', is => 'rw' ); has content => ( isa => 'Str', is => 'rw', lazy => 1, default => sub { ($_[0]->_load)[0] }, ); has content_type => ( isa => 'Str', is => 'rw', lazy => 1, default => sub { ($_[0]->_load)[1] }, ); sub parse { my $self = shift; my $tree = shift; my $need_delete = not blessed $tree; $tree = $self->html_tree( html => $tree ) unless blessed $tree; my $tr = $tree->find_by_tag_name('tr'); my $b = $tr->find_by_tag_name('b'); # name lives here if ($b) { my $name = $b->content_array_ref->[0]; $name =~ s/^\s+//; $name =~ s/\s+$//; $self->name($name); # google code doesn't parse download's content type at all, we need to # figure it out by ourselves my $content_type = $self->_mime_type; if ( $content_type ) { $self->content_type( $content_type ); } } my @tds = $tr->find_by_tag_name('td'); if (@tds) { $self->url( $tds[0]->find_by_tag_name('a')->attr('href') ); if ( $self->url =~ /aid=(-?\d+)/ ) { my $id = $1; $self->id( $id ); } if ( $tds[1] ) { my $size = $tds[1]->content_array_ref->[2]; if ( $size && $size =~ /([\d.]+)\s*(\w+)/ ) { $self->size("$1 $2"); } else { warn 'failed to parse size' unless $size; } } } $tree->delete if $need_delete; return 1; } sub parse_attachments { my $self = shift; my $element = shift; my $need_delete = not blessed $element; $element = $self->html_tree( html => $element ) unless blessed $element; my @attachments; my @items = $element->find_by_tag_name('tr'); while ( scalar @items ) { my $tr = shift @items; my $a = Net::Google::Code::Issue::Attachment->new; if ( $a->parse( $tr ) ) { push @attachments, $a; } } $element->delete if $need_delete; return @attachments; } sub _load { my $self = shift; #XXX weird happens if the previous fetch is also an attachment, # which will make the following fetch a Bad Request. $self->fetch( 'http://code.google.com' ); my $content = $self->fetch( $self->url ); # in case MIME::Types failed to get, let File::MMagic rescue! my $content_type = $self->_mime_type || File::MMagic->new->checktype_contents($content) || 'application/octet-stream'; $self->content( $content ); $self->content_type( $content_type ); return $content, $content_type; } sub _mime_type { my $self = shift; my $mime_type = MIME::Types->new->mimeTypeOf( $self->name ); return $mime_type ? $mime_type->type : undef; } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Issue::Attachment - Issue's Attachment =head1 DESCRIPTION This class represents a single attachment for an issue or an issue's comment. =head1 INTERFACE =over 4 =item parse( HTML::Element or [ HTML::Element, HTML::Element ] or html segment string ) there're 2 trs that represent an attachment like the following: proxy_settings.png 14.3 KB Download =cut =item parse_attachments( HTML::Element or html segment string ) given the
...
or its equivalent HTML::Element object, return a list of Net::Google::Code::Attachment objects. =item name =item content =item size =item url =item id =item content =item content_type =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/Base.pm000644 000765 000120 00000004137 11330470234 022767 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Issue::Base; use Any::Moose; use LWP::UserAgent; has 'project' => ( isa => 'Str', is => 'rw', ); has 'token' => ( isa => 'Str', is => 'rw', ); no Any::Moose; __PACKAGE__->meta->make_immutable; sub feeds_issues_url { my $self = shift; return 'http://code.google.com/feeds/issues/p/' . $self->project . '/issues'; } sub ua { my $self = shift; my $skip_auth = shift; require Net::Google::Code; my $ua = LWP::UserAgent->new( agent => 'net-google-code-issue/' . $Net::Google::Code::VERSION ); return $ua if $skip_auth; $ua->default_header( 'Content-Type' => 'application/atom+xml' ); # get auth token if ( $self->email && $self->password && !$self->token ) { $self->get_token(); } $ua->default_header( Authorization => 'GoogleLogin auth=' . $self->token ) if $self->token; return $ua; } sub get_token { my $self = shift; my $ua = $self->ua(1); # don't need auth my $response = $ua->post( 'https://www.google.com/accounts/ClientLogin', { Email => $self->email, Passwd => $self->password, service => 'code', } ); if ( $response->is_success && $response->content =~ /Auth=(\S+)/ ) { $self->token($1); } else { warn "failed to get auth token: " . $response->status_line . "\n" . $response->content; return; } } 1; __END__ =head1 NAME Net::Google::Code::Issue::Base - Base =head1 SYNOPSIS use Net::Google::Code::Issue::Base; =head1 ATTRIBUTES =over 4 =item auth =back =head1 INTERFACE =over 4 =item feeds_issues_url =item ua returns an L object, with agent and auth stuff prefilled. =item get_token try to get auth token and set $self->token if succeed. =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/Comment.pm000644 000765 000120 00000017656 11357075011 023534 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Issue::Comment; use Any::Moose; use Net::Google::Code::Issue::Attachment; use Net::Google::Code::Issue::Util; use Net::Google::Code::DateTime; with 'Net::Google::Code::Role::HTMLTree'; extends 'Net::Google::Code::Issue::Base'; with 'Net::Google::Code::Role::Authentication'; use Params::Validate ':all'; use XML::FeedPP; has 'updates' => ( isa => 'HashRef', is => 'rw', default => sub { {} } ); has 'author' => ( isa => 'Str', is => 'rw' ); has 'content' => ( isa => 'Str', is => 'rw' ); has 'sequence' => ( isa => 'Int', is => 'rw' ); has 'date' => ( isa => 'DateTime', is => 'rw' ); has 'attachments' => ( isa => 'ArrayRef[Net::Google::Code::Issue::Attachment]', is => 'rw', default => sub { [] }, ); has 'issue_id' => ( isa => 'Int', is => 'rw', ); sub parse { my $self = shift; my $element = shift; my $need_delete = not blessed $element; $element = $self->html_tree( html => $element ) unless blessed $element; my $author = $element->look_down( class => 'author' ); my @a = $author->find_by_tag_name('a'); $self->sequence( $a[0]->content_array_ref->[0] ); $self->author( $a[1]->content_array_ref->[0] ); $self->date(Net::Google::Code::DateTime->new_from_string( $element->look_down( class => 'date' )->attr('title') )); my $content = $element->find_by_tag_name('pre')->as_text; $content =~ s/^\s+//; $content =~ s/\s+$//; $content =~ s/\r\n/\n/g; $self->content($content) unless $content eq '(No comment was entered for this change.)'; my $updates = $element->look_down( class => 'updates' ); if ($updates) { my $box_inner = $element->look_down( class => 'box-inner' ); my $content = $box_inner->content_array_ref; while (@$content) { my $tag = shift @$content; my $value = shift @$content; if ( ref $value && $value->as_HTML =~ m!
! ) { # this happens when there's no value for $tag $value = ''; } else { shift @$content; # this is for the
} my $key = $tag->content_array_ref->[0]; $key =~ s/:$//; $value =~ s/^\s+//; $value =~ s/\s+$//; if ( $key eq 'Labels' ) { # $value here is like "-Pri-2 -Area-Unknown Pri-3 Area-BrowserUI" my @items = split /\s+/, $value; for my $value (@items) { push @{$self->updates->{labels}}, $value; } } else { $self->updates->{ lc $key } = $value; } } } my $att_tag = $element->look_down( class => 'attachments' ); my @attachments; @attachments = Net::Google::Code::Issue::Attachment->parse_attachments($att_tag) if $att_tag; $self->attachments( \@attachments ); $self->delete if $need_delete; return 1; } sub parse_hybrid { my $self = shift; my $element = shift; my $need_delete = not blessed $element; $element = $self->html_tree( html => $element ) unless blessed $element; my $updates = $element->look_down( class => 'updates' ); if ($updates) { my $box_inner = $element->look_down( class => 'box-inner' ); my $content = $box_inner->content_array_ref; while (@$content) { my $tag = shift @$content; my $value = shift @$content; if ( ref $value && $value->as_HTML =~ m!
! ) { # this happens when there's no value for $tag $value = ''; } else { shift @$content; # this is for the
} my $key = $tag->content_array_ref->[0]; $key =~ s/:$//; $value =~ s/^\s+//; $value =~ s/\s+$//; if ( $key ne 'Labels' ) { $self->updates->{ lc $key } = $value; } } } my $att_tag = $element->look_down( class => 'attachments' ); my @attachments; @attachments = Net::Google::Code::Issue::Attachment->parse_attachments($att_tag) if $att_tag; $self->attachments( \@attachments ); $element->delete if $need_delete; return 1; } sub _load_from_xml { my $self = shift; my $ref = Net::Google::Code::Issue::Util->translate_from_xml( shift, type => 'comment' ); for my $k ( keys %$ref ) { if ( $self->can($k) ) { $self->{$k} = $ref->{$k}; } } return $self; } sub list { my $self = shift; validate( @_, { max_results => { optional => 1, type => SCALAR }, } ); my %args = ( max_results => 1_000_000_000, @_ ); my $url = $self->feeds_issues_url . '/' . $self->issue_id . '/comments/full?'; require URI::Escape; for my $k ( keys %args ) { next unless $args{$k}; my $v = $args{$k}; $k =~ s/_/-/g; $url .= "$k=" . URI::Escape::uri_escape($v) . '&'; } my $ua = $self->ua; my $res = $ua->get($url); if ( $res->is_success ) { my $feed = XML::FeedPP->new($res->content); my @items = $feed->get_item; my @list = map { my $t = Net::Google::Code::Issue::Comment->new( map { $_ => $self->$_ } grep { $self->$_ } qw/project email password token issue_id/ ); $t->_load_from_xml($_); } @items; return wantarray ? @list : \@list; } else { die "try to get $url failed: " . $res->status_line . "\n" . $res->content; } } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Issue::Comment - Issue's Comment =head1 DESCRIPTION =head1 ATTRIBUTES =over 4 =item project project name =item email, password user's email and password =item issue_id =item sequence sequence number, initial comment( when you create an issue ) has sequence 0 =item date =item content =item author =item updates HashRef that reflects updates =item attachments =back =head1 INTERFACE =over 4 =item parse( HTML::Element or html segment string ) parse format like the following: Comment 18 by jsykari, Sep 03, 2008 
haha
proxy_settings.png
14.3 KB Download
Cc: thatan...@google.com
Status: Available
Labels: Mstone-X
=item list google's api way to get list of comments return a list of loaded( no scraping is done here ) comments in list context, a ref to the list otherwise. =item parse_hybrid when C<$Net::Google::Code::Issue::USE_HYBRID> is true, we will try to load comments with the google's official api, but as the api is not complete, we still need to do scraping to load something( e.g. attachments ), this method is used to do this. =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/Search.pm000644 000765 000120 00000012073 11330470234 023320 0ustar00sunnavyadmin000000 000000 package Net::Google::Code::Issue::Search; use Any::Moose; use Params::Validate qw(:all); use Any::Moose 'Util::TypeConstraints'; with 'Net::Google::Code::Role::URL'; with 'Net::Google::Code::Role::Fetchable'; with 'Net::Google::Code::Role::Pageable'; with 'Net::Google::Code::Role::HTMLTree'; use Net::Google::Code::Issue; our %CAN_MAP = ( 'all' => 1, 'open' => 2, 'new' => 6, 'verify' => 7, ); has 'project' => ( isa => 'Str', is => 'rw', ); has 'results' => ( isa => 'ArrayRef[Net::Google::Code::Issue]', is => 'rw', default => sub { [] }, ); sub updated_after { my $self = shift; my ( $after, $fallback_to_search ) = validate_pos( @_, { isa => 'DateTime' }, { optional => 1, default => 1 } ); my @results; my $content = $self->fetch( $self->base_feeds_url . 'issueupdates/basic' ); require Net::Google::Code::AtomParser; my $atom_parser = Net::Google::Code::AtomParser->new; my ( $feed, $entries ) = $atom_parser->parse( $content ); if (@$entries) { my $min_updated = Net::Google::Code::DateTime->new_from_string( $entries->[-1]->{updated} ); if ( $min_updated < $after ) { # yeah! we can get all the results by parsing the feed my %seen; for my $entry (@$entries) { my $updated = Net::Google::Code::DateTime->new_from_string( $entry->{updated} ); next unless $updated >= $after; if ( $entry->{title} =~ /issue\s+(\d+)/i ) { next if $seen{$1}++; push @results, Net::Google::Code::Issue->new( project => $self->project, id => $1, ); } } $_->load for @results; return $self->results( \@results ); } } return unless $fallback_to_search; # now we have to find issues by search if ( $self->search( load_after_search => 1, can => 'all', q => '' ) ) { my $results = $self->results; @$results = grep { $_->updated >= $after } @$results; } } sub search { my $self = shift; my %args = ( limit => 999_999_999, load_after_search => 1, can => 2, colspec => 'ID+Type+Status+Priority+Milestone+Owner+Summary', @_ ); if ( $args{can} !~ /^\d$/ ) { $args{can} = $CAN_MAP{ $args{can} }; } my @results; my $mech = $self->mech; my $url = $self->base_url . 'issues/list?'; for my $type (qw/can q sort colspec/) { next unless defined $args{$type}; $url .= $type . '=' . $args{$type} . '&'; } $self->fetch($url); die "Server threw an error " . $mech->response->status_line . 'when search' unless $mech->response->is_success; my $content = $mech->response->content; utf8::downgrade( $content, 1 ); if ( $mech->title =~ /issue\s+(\d+)/i ) { # get only one ticket my $issue = Net::Google::Code::Issue->new( project => $self->project, id => $1, ); @results = $issue; } elsif ( $mech->title =~ /issues/i ) { # get a ticket list my @rows = $self->rows( html => $content, limit => $args{limit}, ); for my $row (@rows) { push @results, Net::Google::Code::Issue->new( project => $self->project, %$row, ); } } else { warn "no idea what the content like"; return; } if ( $args{load_after_search} ) { $_->load for @results; } $self->results( \@results ); } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Net::Google::Code::Issue::Search - Issues Search API =head1 DESCRIPTION =head1 INTERFACE =over 4 =item search ( can => 'all', q = 'foo', sort => '-modified', limit => 1000, load_after_search => 1 ) do the search, the results is set to $self->results, which is an arrayref with Net::Google::Code::Issue as element. If a "sort" argument is specified, that will be passed to google code's issue list. Generally, these are composed of "+" or "-" followed by a column name. limit => Num is to limit the results number. load_after_search => Bool is to state if we should call $issue->load after search return true if search is successful, false on the other hand. =item updated_after( date_string || DateTime object ) find all the issues that have been updated or created after the date. the issues are all loaded. return true if success, false on the other hand =item project =item results this should be called after a successful search. returns issues as a arrayref. =back =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2008-2010 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/lib/Net/Google/Code/Issue/Util.pm000644 000765 000120 00000016274 11357073743 023054 0ustar00sunnavyadmin000000 000000 use strict; use warnings; package Net::Google::Code::Issue::Util; use Net::Google::Code::Role::HTMLTree; use DateTime; use XML::TreePP; my $tpp = XML::TreePP->new; $tpp->set( output_encoding => 'UTF-8' ); $tpp->set( utf8_flag => 1 ); sub write_xml { my $self = shift; return $tpp->write(shift); } sub translate_from_xml { my $class = shift; my $ref = shift; return unless $ref; my %args = @_; die "invalid type: $args{type}" unless $args{type} =~ /^(issue|comment)$/; %$ref = map { my $new = $_; $new =~ s/^issues://g; $new => $ref->{$_} } keys %$ref; for my $k ( keys %$ref ) { if ( $k eq 'id' ) { if ( $args{type} eq 'issue' ) { $ref->{id} = $1 if $ref->{id} =~ /(\d+)$/; } elsif ( $args{type} eq 'comment' ) { $ref->{sequence} = $1 if $ref->{id} =~ /(\d+)$/; delete $ref->{id}; } } if ( $k eq 'title' ) { if ( $args{type} eq 'issue' ) { $ref->{summary} = $ref->{$k}; delete $ref->{$k}; } } if ( $k eq 'author' ) { if ( $args{type} eq 'issue' ) { $ref->{reporter} = $ref->{$k}->{name}; delete $ref->{author}; } elsif ( $args{type} eq 'comment' ) { $ref->{author} = $ref->{$k}->{name}; } } elsif ( $k eq 'content' ) { my $text; if ( $ref->{$k}{-type} eq 'html' ) { my $tree = Net::Google::Code::Role::HTMLTree->html_tree( html => '
'
                      . ( $ref->{$k}->{'#text'} || '' )
                      . '
' ); $text = $tree->as_text if $tree; $tree->delete; } else { $text = $ref->{$k}->{'#text'}; } $text =~ s/\s+$// if $text; if ( $args{type} eq 'issue' ) { $ref->{description} = $text; delete $ref->{$k}; } elsif ( $args{type} eq 'comment' ) { $ref->{content} = $text; } } elsif ( $k eq 'published' ) { if ( $args{type} eq 'issue' ) { $ref->{reported} = $class->datetime_from_string( $ref->{$k} ); } elsif ( $args{type} eq 'comment' ) { $ref->{date} = $class->datetime_from_string( $ref->{$k} ); } } elsif ( $k eq 'updated' ) { $ref->{$k} = $class->datetime_from_string( $ref->{$k} ); } elsif ( $k eq 'owner' ) { my $tmp = {}; my $value = $ref->{$k}; $ref->{$k} = $value->{'issues:username'}; } elsif ( $k eq 'cc' ) { my @cc = ref $ref->{$k} eq 'ARRAY' ? @{ $ref->{$k} } : $ref->{$k}; $ref->{$k} = []; for my $cc (@cc) { push @{$ref->{$k}}, $cc->{'issues:username'}; } } elsif ( $k eq 'label' ) { $ref->{labels} = ref $ref->{$k} eq 'ARRAY' ? $ref->{$k} : [ $ref->{$k} ]; delete $ref->{label}; } elsif ( $k eq 'updates' ) { my $tmp = {}; my $value = $ref->{updates}; for my $k ( keys %$value ) { my $v = $value->{$k}; $k =~ s/^issues://; $k .= 's' if $k eq 'label'; $k =~ s/Update$//; $tmp->{$k} = $v; } if ( exists $tmp->{labels} && !ref $tmp->{labels} ) { $tmp->{labels} = [ $tmp->{labels} ]; } $ref->{$k} = $tmp; } } return $ref; } sub translate_to_xml { my $self = shift; my $ref = shift; my %args = @_; my %entry; if ( $args{type} eq 'create' ) { for my $key ( keys %$ref ) { if ( $key eq 'author' ) { $entry{'author'}{'name'} = $ref->{$key}; } elsif ( $key eq 'comment' ) { $entry{'content'} = $ref->{$key}; } elsif ( $key eq 'summary' ) { $entry{'title'} = $ref->{$key}; } elsif ( $key eq 'cc' ) { $entry{'issues:cc'}{'issues:username'} = $ref->{$key}; } elsif ( $key eq 'owner' ) { $entry{'issues:owner'}{'issues:username'} = $ref->{$key}; } elsif ( $key eq 'labels' ) { $entry{'issues:label'} = $ref->{$key}; } else { $entry{"issues:$key"} = $ref->{$key}; } } } elsif ( $args{type} eq 'update' ) { for my $key ( keys %$ref ) { if ( $key eq 'author' ) { $entry{'author'}{'name'} = $ref->{$key}; } elsif ( $key eq 'comment' ) { $entry{'content'} = $ref->{$key}; } elsif ( $key eq 'cc' ) { $entry{'issues:updates'}{'issues:ccUpdate'} = $ref->{$key}; } elsif ( $key eq 'owner' ) { $entry{'issues:updates'}{'issues:ownerUpdate'} = $ref->{$key}; } elsif ( $key eq 'labels' ) { $entry{'issues:updates'}{'issues:label'} = $ref->{$key}; } else { $entry{'issues:updates'}{"issues:$key"} = $ref->{$key}; } } } else { die "invalid type: $args{type}"; } $ref = { entry => \%entry }; my $xml = Net::Google::Code::Issue::Util->write_xml($ref); $xml =~ s!!!; return $xml; } sub datetime_from_string { my $class = shift; my $string = shift; return unless $string; if ( $string =~ /(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})(?:\.000)?(Z|[+-]\d{2}:\d{2})/ ) { # 2009-06-01T13:00:10Z my $dt = DateTime->new( year => $1, month => $2, day => $3, hour => $4, minute => $5, second => $6, time_zone => $7 eq 'Z' ? 'UTC' : $7, ); $dt->set_time_zone( 'UTC' ); } } 1; __END__ =head1 NAME Net::Google::Code::Issue::Util - Util =head1 SYNOPSIS use Net::Google::Code::Issue::Util; =head1 DESCRIPTION utility methods live here =head1 INTERFACE =over 4 =item write_xml wrap of XML::TreePP->write =item translate_from_xml( $hashref | $xml_string ) translate from xml, the general translation map is: 'issues:stars' => 'stars', value datetime string => L object =item translate_to_xml( $hashref, root => 'project', boolean => ['foo','bar'] ) generally, the reverse of translate_from_xml. =item datetime_from_string parse string to a L object, and translate its timezone to UTC =back =head1 SEE ALSO L =head1 AUTHOR sunnavy C<< >> =head1 LICENCE AND COPYRIGHT Copyright 2009 Best Practical Solutions. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Google-Code-0.19/inc/Module/000755 000765 000120 00000000000 11366126703 017106 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/inc/Module/AutoInstall.pm000644 000765 000120 00000053306 11365741055 021714 0ustar00sunnavyadmin000000 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'; } 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; if ( $CPAN::HandleConfig::VERSION ) { # 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 1056 Net-Google-Code-0.19/inc/Module/Install/000755 000765 000120 00000000000 11366126703 020514 5ustar00sunnavyadmin000000 000000 Net-Google-Code-0.19/inc/Module/Install.pm000644 000765 000120 00000024114 11365741055 021056 0ustar00sunnavyadmin000000 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 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 = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # 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 # 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)); use Cwd (); use File::Find (); use File::Path (); use FindBin; 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; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 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 import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } 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 ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^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) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $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; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } 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; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _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 - 2009 Adam Kennedy. Net-Google-Code-0.19/inc/Module/Install/AuthorTests.pm000644 000765 000120 00000002215 11365741055 023341 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Net-Google-Code-0.19/inc/Module/Install/AutoInstall.pm000644 000765 000120 00000002273 11365741055 023317 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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; Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); $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-Google-Code-0.19/inc/Module/Install/Base.pm000644 000765 000120 00000001766 11365741055 021740 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # 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->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Net-Google-Code-0.19/inc/Module/Install/Can.pm000644 000765 000120 00000003333 11365741055 021557 0ustar00sunnavyadmin000000 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 = '0.91'; @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-Google-Code-0.19/inc/Module/Install/Fetch.pm000644 000765 000120 00000004627 11365741055 022116 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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-Google-Code-0.19/inc/Module/Install/Include.pm000644 000765 000120 00000001015 11365741055 022434 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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-Google-Code-0.19/inc/Module/Install/Makefile.pm000644 000765 000120 00000016003 11365741055 022571 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; 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 ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } 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. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } 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->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $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: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $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; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 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 394 Net-Google-Code-0.19/inc/Module/Install/Metadata.pm000644 000765 000120 00000035304 11365741055 022601 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author 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 }; 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; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', 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()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } 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"); } # 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) ); } 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 perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $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; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => '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, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; 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 on rt.cpan.org 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; } ###################################################################### # 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-Google-Code-0.19/inc/Module/Install/Win32.pm000644 000765 000120 00000003403 11365741055 021756 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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-Google-Code-0.19/inc/Module/Install/WriteAll.pm000644 000765 000120 00000002222 11365741055 022575 0ustar00sunnavyadmin000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @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} ) { $self->makemaker_args( PL_FILES => {} ); } # 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;