XML-Atom-0.41/000755 000771 000024 00000000000 11640225176 013737 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/.shipit000644 000771 000024 00000000427 11174274626 015251 0ustar00miyagawastaff000000 000000 steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN # if directory, where the normal "make dist" puts its file. #MakeDist.destination = ~/shipit-dist #svn.tagpattern = ShipIt-%v #CheckChangeLog.files = ChangeLog git.push_to = origin XML-Atom-0.41/Changes000644 000771 000024 00000032206 11640225136 015231 0ustar00miyagawastaff000000 000000 $Id$ Revision history for XML::Atom 0.41 2011.09.26 * Added a dependency to DateTime::TimeZone (leto) 0.40 2011.09.18 * Fixed tests for Windows (wchristian) * use all upper case UTF-8 (tsgit) 0.39 2011.06.20 * Disabled external entities and network to avoid possible security flaw (yannk) 0.38 2011.05.22 * Fixed a bug where content with newlines wasn't encoded in perl >= 5.12 (emasaka) https://rt.cpan.org/Public/Bug/Display.html?id=61637 0.37 2009.12.29 * Fixed accessors for source elements (Vince Veselosky) 0.36 2009.12.21 * Fixed various dependency issues RT #23538, #34481, #52519, #41058 (Tomas Doran) 0.35 2009.05.01 * reworked Module::Install stuff to remove junks 0.34 2009.04.29 * Fixed $entry->source support (Martin Atkins) 0.33 2009.01.06 * Client: Send WSSE auth header only when username is set (Thanks to David Bourget at http://rt.cpan.org/Public/Bug/Display.html?id=42201) 0.32 2008.11.23 * Added base and lang to Entry and Feed object. Fixed xml:base attributes. (Simon Wistow) 0.31 2008.11.13 * Update Content-Type in XML::Atom::Client when the entity's version >= 1.0 (Thanks to David Steinbrunner RT 39801) 0.30 2008.11.12 * hopefully fix a bug where xml:base returns an empty string e.g. http://www.nntp.perl.org/group/perl.cpan.testers/2008/11/msg2595696.html (Thanks to tokuhirom http://d.hatena.ne.jp/tokuhirom/20081110/1226280757) 0.29 2008.10.25 * Skips Unicode tests since it doesn't pass with some libxml versions (and it's not actually a bug) 0.28 2007.11.06 * Fixed Namespace handling in extensions so that both URL and NS object work (Thanks to Brian Cassidy) 0.27_01 2007.10.04 * Removes most of hacks to deal with LibXML insane unicode stuff which are fixed with 1.64 0.27 2007.09.15 * Fixed $feed->as_xml_utf8 to work with latest XML::LibXML 0.26 2007.09.15 * This be 0.26 0.25_02 2007.06.20 * Fixed tests that fail with newer libxml (Thanks to knagano) 0.25_01 2007.04.27 * Fixed XML::Atom::Base element accessor to work with attributes (Patch from LTjake and Jshirley for OpenSearch extension) * Make XML::Atom::Link easily subclassable (Patch from Simon Wistow for Google Calendar support) 0.25 2006.11.30 * Fixed memory leaks in XML::Atom::Client (Reported by Brian Cassidy) 0.24 2006.11.25 * Updated document to mention that ID creation is user's responsibility * Added $feed->as_xml_utf8 which always returns UTF-8 bytes string, rather than UTF-8 flagged one. This addresses annoying issues with UTF-8 vs. latin-1 (Thanks to Rui Vilela #21191) * Better fix for the hateful default: prefix issue in libxml2; now we remove the default\d* prefix on any nodes and set the proper namespace URI. * Fix to the test case since 0x242 is now printable character in bleadperl (Thanks to Andreas Koenig and Steve Peters) * Skip tests if 'euc-jp' is unknown encoding on your XML library (via CPAN testers) 0.23 2006.08.27 * Fixed the method to get xml:lang and xml:base due to the XML::LibXML 1.60 change which invalidated it. 0.22 2006.07.24 * Refactored internal element accessors by eating the new dog food mk_elem_accessors and mk_object_list_accessor. * Added support of Atom 1.0 parse and generation * Added $thing->links and $thing->categories as a moniker method that returns an array reference in a scalar context * Fixed a bug in $content->body() where it accidentally thinks the content is not a valid Unicode string even if it is, if you call eval {} in elsewhere in the code and $@ is left set. (Thanks to Chris Dent for the patch) 0.21 2006.07.13 * propagate $entry's version when we create content element off of entry using $entry->content("foo") syntax. (Thanks to Simon Wistow for spotting this bug) 0.20 2006.07.12 * Lots of refactoring, which simplifies much of the code in the various construct modules (Person, Link, etc), and which should also make it much more straightforward to add extension classes in the future. * Added global $XML::Atom::ForceUnicode flag to return everything as Unicode flagged (Suggested by many people) * Added global $XML::Atom::DefaultVersion flag to set default version number for generated Atom feed. Defaults to 0.3 (for backward compatibility) * Added support for atom:content @type in Atom 1.0 feeds (Suggested by many people, especially Chris Dent and Andy Lester from Socialtext) 0.19 2006.03.19 * Fix 0.18 bug where renaming stuff was totally broken. 0.18 2006.03.16 * Support Atom 0.3 -> 1.0 renaming bits (issued -> published, modified -> updated, tagline -> subtitle) * $atom->content->body doesn't return Unicode flagged variable anymore, even if it's text/ data. Now it just returns UTF-8 bytes. (Thanks to Garth Webb) 0.17 2006.02.22 * Fixed problem with XML::XPath 0.16 2005.11.22 * Fixed a terrible bug when you set binary data to $entry->content 0.15 2005.11.01 - Fixed bug found in mode => 'insert' (Thanks to Dominic Mitchell) 0.14 2005.10.21 - Fixed bug that it decodes binary data as UTF-8 octet (Thanks to Mahlon E. Smith) - Don't eat up STDIN in cgi-mode (Thanks to Bayle Shanks) 0.13_02 - Now supports insert mode, by passing hash reference in add_entry $feed->add_entry($entry, { mode => 'insert' }); (Thanks to Dominic Mitchell) 0.13_01 2005.09.13 - Now supports creating version 1.0 feed by passing new(Version => 1.0) - Be more strict in utf-8 handling and base64ing (Thanks to Dave Rolsky) 0.13 2005.08.18 - Bumped up the version 0.12_02 - $feed->version now returns 1.0 when xmlns patches with that for 1.0 - Fixed segmentation fault problem with longer than 2.5k (Thanks to Chris Dent and Ryan King) - No unicode decode hack on content withou mode="xml" 0.12_01 2005.07.19 - Added Atom 1.0 feed support for parsing - Hacked Unicode entity in $content->body - Added $entry->contributor - $entry->contributor and $entry->person returns list in list context - Added $content->lang and $content->base (xml:lang and xml:base) - Make sure $feed->as_xml doesn't set utf-8 flag 0.12 2005.06.07 - Documentation fixes for XML::Atom::Server. Thanks to Tatsuhiko Miyagawa for the patch. - Removed XML::LibXSLT usage. Too much pain for too little gain. To be clear: all it was doing was namespace normalization, so removing it should make no difference. - Fixed _utf8_off bug in XML::Atom::Client that causes fatal error in POSTing multibyte content (Tatsuhiko Miyagawa, Masayoshi Sekimura) - Added XML::Atom::Thing::add method to allow $entry->add() (Tatsuhiko Miyagawa) 0.11 2005.02.23 - Remove the default: namespace when converting to XML using as_xml (the earlier fix only fixed it when getting the contents of an entry using $entry->content). - UTF-8 data is no longer base64-encoded in XML::Atom::Content. Thanks to Tatsuhiko Miyagawa for the patch. - Added XML::Atom::Entry::getlist($ns, $element) to retrieve the values of an element that may appear multiple times in the entry (like dc:subject). Thanks to Tatsuhiko Miyagawa for the patch. - Added ability to set namespaced attributes in an XML::Atom::Link object. Thanks to Tatsuhiko Miyagawa for the patch. - XML::Atom::Entry::add_link($link) no longer clones $link if it's a XML::Atom::Link object. Thanks to Tatsuhiko Miyagawa for the patch. 0.10 2004.12.31 - Eliminated unitialized value warning on attributes that aren't set. - Added XML::Atom::Feed->version to get and set the version of the feed. - XML::Atom::Feed->language can now be used to set the language of the feed. - Added support for using XML::XPath in XML::Atom::Server. Thanks to Autrijus Tang for the patch. 0.09 2004.07.29 - Fixed "500 Malformed characters in syswrite" bug with utf-8. Thanks to Tatsuhiko Miyagawa for the patch. - Fixed bug in server where empty XML response would cause an error. Thanks to Tatsuhiko Miyagawa for the patch. 0.08 2004.06.01 - Added XML::Atom::Feed::language method, which returns the language of the feed (from 'xml:lang'). - Added XML::Atom::Feed::author, which returns a XML::Atom::Person object representing the element. - Remove the default: namespace prefix that XML::LibXML adds inside elements. - Use LWP::Authen::Wsse module for WSSE authentication when in REST mode, which handles redirects properly. 0.07 2004.05.15 - Added (experimental) support for using XML::XPath as an alternative to XML::LibXML. This is detected automatically upon loading XML::Atom; XML::LibXML is still the default. - WSSE authentication tokens now persist properly across server redirects. Thanks to Autrijus Tang for the patch. - Fixed bug where empty password (empty string or "0") would cause an invalid login in Atom server core. Also, improved error message on invalid password for security. Thanks to Tatsuhiki Miyagawa for the patch. 0.06 2004.04.14 - BACKWARDS INCOMPATIBILITY: Fixed Nonce behavior in API. Nonce should be sent in base64-encoded form in SOAP and REST requests, but decoded (raw) nonce should be used when generating PasswordDigest. - Feed->add_link and Entry->add_link now support the same hash reference parameter style as used in 0.041 and below, in addition to the XML::Atom::Link parameter. - Fixed bug with Feed->link so that it no longer returns links that are contained within elements within the . 0.05 2004.01.05 - BACKWARDS INCOMPABILITY: Removed XML::Atom::Entry::get_links and XML::Atom::Feed::get_links, in favor of new link() method in both classes, which returns a list of XML::Atom::Link objects. Also, add_link() now expects an XML::Atom::Link object instead of a hash reference. - BACKWARDS INCOMPABILITY: Renamed XML::Atom::API to XML::Atom::Client. - Added XML::Atom::Link, an encapsulation of the tag in a feed or an entry. - Added XML::Atom::Server, an implementation of an Atom core server (to be subclassed for implementation-specific methods). - Fixed feed auto-discovery to work with all client tests at http://diveintomark.org/tests/client/autodiscovery/ - Added (and documented) XML::Atom::Feed->find_feeds, to return all of the Atom feed URIs on a page given a URI. - Fixed issue with PasswordDigest in API (use sha(), not hex(sha()) for generating password digest). - Stream parameter to XML::Atom::Entry::new and XML::Atom::Feed::new is now optional; if passed only one parameter, it's assumed to be the Stream parameter. - Fixed bug in XML::Atom::Content::as_xml (it didn't work). 0.041 2003.12.15 - Fixed issue with calling $entry->content on list of entries generated from $feed->entries. (Thanks to esummers for the report.) 0.04 2003.12.14 - BACKWARDS INCOMPABILITY: elements are now represented as XML::Atom::Content objects instead of just get/set accessors. You can still set XML::Atom::Entry::content with a scalar (it will be automatically upgraded to an XML::Atom::Content object), but to get the value of , you need to call XML::Atom::Content::Body. For example: $entry->content->body - XML::Atom::Entry::content now removes the
wrapper from XHTML when called with no arguments. - Changed XML::Atom::Author to XML::Atom::Person and re-implemented it. - Changed "WSSE" to "UsernameToken" in X-WSSE header. 0.03 2003.12.05 - Added XML::Atom::Author to represent author or contributor, with accessors for name, email, URL, etc. - Updated XML::Atom::API per the 08 API spec: * Removed searchEntries and replaced it with getFeed * Removed introspection and replaced it with URI parameters to createEntry and getFeed (introspection will be added back in once it is more locked down) - Added support for easily adding tags to feed or entry (eg XML::Atom::Feed::add_link) and getting tags from feed or entry (eg XML::Atom::Feed::get_links). - Fixed XML::Atom::Thing::get to return undef when an element is not found in the object at all (it used to return the empty string). 0.02 2003.09.28 - Completely revamped authentication mechanism to use X-WSSE header (or corresponding SOAP headers). - Removed 03-client.t test, because there aren't any publicly available servers to test against. (Are there?) - Added support for SOAP wrapper in API client. - Added namespace support in XML::Atom::Namespace using get and set methods in XML::Atom::Entry and XML::Atom::Feed. - Added namespace normalization for produced XML (if XML::LibXSLT is installed). This is really just a cosmetic thing. 0.01 2003.09.07 - Initial distribution. XML-Atom-0.41/inc/000755 000771 000024 00000000000 11640225176 014510 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/lib/000755 000771 000024 00000000000 11640225176 014505 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/Makefile.PL000644 000771 000024 00000001323 11640225106 015701 0ustar00miyagawastaff000000 000000 # $Id$ use inc::Module::Install; use 5.008; name 'XML-Atom'; all_from 'lib/XML/Atom.pm'; auto_set_repository; requires('MIME::Base64'); requires('URI'); requires('Class::Data::Inheritable'); requires('XML::XPath'); requires('LWP::UserAgent'); requires('Digest::SHA1'); requires('DateTime'); requires('DateTime::TimeZone'); requires('XML::LibXML', 1.69); features( 'Pure perl XML parsing with XML::XPath' => [ -default => 0, 'XML::XPath' => 0, ], 'Client/Server for Atom API' => [ -default => 1, LWP => 0, 'LWP::Authen::Wsse' => 0, ], 'Feed and API Auto-discovery' => [ -default => 1, 'HTML::Parser' => 0, ], ); auto_include(); &WriteAll; XML-Atom-0.41/MANIFEST000644 000771 000024 00000002441 11600014251 015053 0ustar00miyagawastaff000000 000000 .shipit Changes inc/Module/Install.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/Repository.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/XML/Atom.pm lib/XML/Atom/Base.pm lib/XML/Atom/Category.pm lib/XML/Atom/Client.pm lib/XML/Atom/Content.pm lib/XML/Atom/Entry.pm lib/XML/Atom/ErrorHandler.pm lib/XML/Atom/Feed.pm lib/XML/Atom/Link.pm lib/XML/Atom/Person.pm lib/XML/Atom/Server.pm lib/XML/Atom/Thing.pm lib/XML/Atom/Util.pm Makefile.PL MANIFEST This list of files META.yml README t/00-compile.t t/01-util.t t/02-content.t t/03-link.t t/04-person.t t/11-entry.t t/12-feed.t t/13-atom1.t t/14-atom1-create.t t/15-content-image.t t/16-content-binary.t t/17-renames.t t/18-unicode.t t/19-ext.t t/20-content-xhtml.t t/23-category.t t/24-bad-content.t t/25-utf8-create.t t/27-client-leaks.t t/28-ext.t t/29-source.t t/30-datetime-stringification.t t/31-external-entities-libxml.t t/31-external-entities-xpath.t t/samples/atom-1.0.xml t/samples/entry-euc.xml t/samples/entry-full.xml t/samples/entry-ns.xml t/samples/entry-utf8.xml t/samples/feed.xml t/samples/lifeblog-atom.xml t/samples/me.jpg t/samples/source.xml t/samples/vox.xml t/TestLib.pm XML-Atom-0.41/META.yml000644 000771 000024 00000001334 11640225176 015211 0ustar00miyagawastaff000000 000000 --- abstract: 'Atom feed and API implementation' author: - 'Benjamin Trott, Tatsuhiko Miyagawa' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.01' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-Atom no_index: directory: - inc - t requires: Class::Data::Inheritable: 0 DateTime: 0 DateTime::TimeZone: 0 Digest::SHA1: 0 LWP::UserAgent: 0 MIME::Base64: 0 URI: 0 XML::LibXML: 1.69 XML::XPath: 0 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/miyagawa/xml-atom.git version: 0.41 XML-Atom-0.41/README000644 000771 000024 00000001057 11174274617 014630 0ustar00miyagawastaff000000 000000 $Id: README,v 1.2 2003/09/08 03:48:07 btrott Exp $ This is XML::Atom, an implementation of the API and feed format. PREREQUISITES * XML::LibXML * LWP * Digest::SHA1 * MIME::Base64 * HTML::Parser INSTALLATION XML::Atom installation is straightforward. If your CPAN shell is set up, you should just be able to do % perl -MCPAN -e 'install XML::Atom' Download it, unpack it, then build it as per the usual: % perl Makefile.PL % make && make test Then install it: % make install Benjamin Trott / cpan@stupidfool.org XML-Atom-0.41/t/000755 000771 000024 00000000000 11640225176 014202 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/t/00-compile.t000644 000771 000024 00000000402 11174274617 016236 0ustar00miyagawastaff000000 000000 # $Id$ use Test::More tests => 6; use_ok('XML::Atom'); use_ok('XML::Atom::Entry'); use_ok('XML::Atom::Feed'); #use_ok('XML::Atom::Client'); #use_ok('XML::Atom::Server'); use_ok('XML::Atom::Person'); use_ok('XML::Atom::Content'); use_ok('XML::Atom::Link'); XML-Atom-0.41/t/01-util.t000644 000771 000024 00000001757 11174274617 015602 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More; use XML::Atom::Util qw( iso2dt ); BEGIN { unless (eval { require DateTime; }) { plan skip_all => 'DateTime is required for tests'; } else { plan tests => 12; } } my %tests = ( '20030928' => '2003-09-28T00:00:00', '2003-09-28' => '2003-09-28T00:00:00', '2003-09-28T12:49:50' => '2003-09-28T12:49:50', '2003-09-28T12:49:50Z' => '2003-09-28T12:49:50', '2003-09-28T12:49:50-00:00' => '2003-09-28T12:49:50', '2003-09-28T12:49:50+00:00' => '2003-09-28T12:49:50', '2003-09-28T12:49:50-01:00' => '2003-09-28T13:49:50', '2003-09-28T12:49:50+01:00' => '2003-09-28T11:49:50', '2003-09-28T12:49:50-01:30' => '2003-09-28T14:19:50', '2003-09-28T12:49:50+01:30' => '2003-09-28T11:19:50', '2003-09-28T12:49:50+17:00' => '2003-09-27T19:49:50', '2003-09-28T12:49:50-17:00' => '2003-09-29T05:49:50', ); for my $test (keys %tests) { is iso2ts($test), $tests{$test}; } sub iso2ts { iso2dt($_[0])->iso8601 } XML-Atom-0.41/t/02-content.t000644 000771 000024 00000005331 11174274617 016270 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 32; use XML::Atom::Content; my $content; $content = XML::Atom::Content->new; isa_ok $content, 'XML::Atom::Content'; ok $content->elem; $content->type('image/jpeg'); is $content->type, 'image/jpeg'; $content->type('application/gzip'); is $content->type, 'application/gzip'; $content = XML::Atom::Content->new('This is a test.'); is $content->body, 'This is a test.'; is $content->mode, 'xml'; $content = XML::Atom::Content->new(Body => 'This is a test.'); is $content->body, 'This is a test.'; is $content->mode, 'xml'; $content = XML::Atom::Content->new(Body => 'This is a test.', Type => 'foo/bar'); is $content->body, 'This is a test.'; is $content->mode, 'xml'; is $content->type, 'foo/bar'; $content = XML::Atom::Content->new; $content->body('This is a test.'); is $content->body, 'This is a test.'; is $content->mode, 'xml'; $content->type('foo/bar'); is $content->type, 'foo/bar'; $content = XML::Atom::Content->new; $content->body('

This is a test with XHTML.

'); is $content->body, '

This is a test with XHTML.

'; is $content->mode, 'xml'; $content = XML::Atom::Content->new; $content->body('

This is a test with invalid XHTML.'); is $content->body, '

This is a test with invalid XHTML.'; is $content->mode, 'escaped'; $content = XML::Atom::Content->new; $content->body("This is a test that should use base64\x7f."); $content->type('text/plain'); is $content->mode, 'base64'; is $content->body, "This is a test that should use base64\x7f."; SKIP: { skip "skip Unicode test since it depends on LibXML", 2; $content = XML::Atom::Content->new; $content->body("My name is \xe5\xae\xae\xe5\xb7\x9d."); is $content->mode, 'xml'; is $content->body, "My name is \xe5\xae\xae\xe5\xb7\x9d."; } $content = XML::Atom::Content->new; $content->type('text/plain'); eval { $content->body("Non-printable: " . chr(0x1034F)) }; is $content->mode, 'base64'; is $content->body, un_utf8("Non-printable: " . chr(0x1034F)); # 1.0 with xhtml $content = XML::Atom::Content->new(Version => 1.0); $content->body("

foo bar
"); is $content->type, 'xhtml'; is $content->body, "
foo bar
"; # 1.0 with html $content = XML::Atom::Content->new(Version => 1.0); $content->body("

foo bar"); is $content->type, 'html'; is $content->body, "

foo bar"; # 1.0 as text $content = XML::Atom::Content->new(Version => 1.0); $content->body("foo bar"); $content->type('text'); is $content->type, 'text'; is $content->body, "foo bar"; # 1.0 as binary $content = XML::Atom::Content->new(Version => 1.0); $content->type('image/jpeg'); $content->body("\xff\xde\xde\xde"); is $content->type, 'image/jpeg'; is $content->body, "\xff\xde\xde\xde"; sub un_utf8 { my $foo = shift; Encode::_utf8_off($foo); $foo; } XML-Atom-0.41/t/03-link.t000644 000771 000024 00000001751 11635444454 015556 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 14; use XML::Atom::Link; my $link; $link = XML::Atom::Link->new; isa_ok $link, 'XML::Atom::Link'; ok $link->elem; $link->title('This is a test.'); is $link->title, 'This is a test.'; $link->title('Different title.'); is $link->title, 'Different title.'; $link->title('This is a test.'); $link->rel('alternate'); is $link->rel, 'alternate'; $link->href('http://www.example.com/'); is $link->href, 'http://www.example.com/'; $link->type('text/html'); is $link->type, 'text/html'; my $xml = $link->as_xml; like $xml, qr/^<\?xml version="1.0" encoding="UTF-8"\?>/; like $xml, qr/new(dc => "http://purl.org/dc/elements/1.1/"); $link->set($ns, "subject" => "blah"); $xml = $link->as_xml; like $xml, qr/dc:subject="blah"/; XML-Atom-0.41/t/04-person.t000644 000771 000024 00000001235 11635444454 016125 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 9; use XML::Atom::Person; my $person; $person = XML::Atom::Person->new; isa_ok $person, 'XML::Atom::Person'; ok $person->elem; $person->name('Foo Bar'); is $person->name, 'Foo Bar'; $person->name('Baz Quux'); is $person->name, 'Baz Quux'; $person->email('foo@bar.com'); is $person->email, 'foo@bar.com'; my $xml = $person->as_xml; like $xml, qr/^<\?xml version="1.0" encoding="UTF-8"\?>/; like $xml, qr//; like $xml, qr/Baz Quux<\/name>/; like $xml, qr/foo\@bar.com<\/email>/; XML-Atom-0.41/t/11-entry.t000644 000771 000024 00000012313 11174274617 015755 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use t::TestLib; use Test::More; use XML::Atom; use XML::Atom::Entry; use XML::Atom::Person; unless ( xmllib_support_encoding('euc-jp') ){ plan skip_all => 'euc-jp is not supported on your XML library'; } plan tests => 71; my $entry; $entry = XML::Atom::Entry->new; $entry->title('Foo Bar'); is $entry->title, 'Foo Bar'; $entry = XML::Atom::Entry->new('t/samples/entry-ns.xml'); isa_ok $entry, 'XML::Atom::Entry'; is $entry->title, 'Unit Test 1'; $entry = XML::Atom::Entry->new(Stream => 't/samples/entry-ns.xml'); is $entry->title, 'Unit Test 1'; my $body = $entry->content->body; ok $body; like $body, qr/^new(Stream => 't/samples/entry-full.xml'); is $entry->title, 'Guest Author'; is $entry->id, 'tag:typepad.com:post:75207'; is $entry->issued, '2003-07-21T02:47:34-07:00'; is $entry->modified, '2003-08-22T18:36:57-07:00'; is $entry->created, '2003-07-21T02:47:34-07:00'; is $entry->summary, 'No, Ben isn\'t updating. It\'s me testing out guest author functionality....'; isa_ok $entry->author, 'XML::Atom::Person'; is $entry->author->name, 'Mena'; $entry->author->name('Ben'); is $entry->author->url, 'http://mena.typepad.com/'; my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/'); is $entry->get($dc->subject), 'Food'; my @subj = $entry->getlist($dc->subject); is scalar(@subj), 2; is $subj[0], 'Food'; is $subj[1], 'Cats'; isa_ok $entry->content, 'XML::Atom::Content'; is $entry->content->body, '

No, Ben isn\'t updating. It\'s me testing out guest author functionality.

'; my @link = $entry->link; is scalar(@link), 2; is $link[0]->rel, 'alternate'; is $link[0]->type, 'text/html'; is $link[0]->href, 'http://ben.stupidfool.org/typepad/2003/07/guest_author.html'; is $link[1]->rel, 'service.edit'; is $link[1]->type, 'application/x.atom+xml'; is $link[1]->href, 'http://www.example.com/atom/entry_id=75207'; is $link[1]->title, 'Edit'; my @links = $entry->links; is scalar(@links), 2; is $links[0]->rel, 'alternate'; my $link = $entry->link; isa_ok $link, 'XML::Atom::Link'; is $link->rel, 'alternate'; is $link->type, 'text/html'; is $link->href, 'http://ben.stupidfool.org/typepad/2003/07/guest_author.html'; $link = XML::Atom::Link->new; $link->title('Number Three'); $link->rel('service.post'); $link->href('http://www.example.com/atom'); $link->type('application/x.atom+xml'); $entry->add_link($link); @link = $entry->link; is scalar(@link), 3; is $link[2]->rel, 'service.post'; is $link[2]->type, 'application/x.atom+xml'; is $link[2]->href, 'http://www.example.com/atom'; is $link[2]->title, 'Number Three'; ## xxx test setting/getting different content encodings ## xxx encodings ## xxx Doc param $entry->title('Foo Bar'); is $entry->title, 'Foo Bar'; $entry->set($dc->subject, 'Food & Drink'); is $entry->get($dc->subject), 'Food & Drink'; ok(my $xml = $entry->as_xml); my $entry2 = XML::Atom::Entry->new(Stream => \$xml); isa_ok $entry2, 'XML::Atom::Entry'; is $entry2->title, 'Foo Bar'; is $entry2->author->name, 'Ben'; is $entry2->get($dc->subject), 'Food & Drink'; isa_ok $entry2->content, 'XML::Atom::Content'; is $entry2->content->body, '

No, Ben isn\'t updating. It\'s me testing out guest author functionality.

'; my $entry3 = XML::Atom::Entry->new; my $author = XML::Atom::Person->new; $author->name('Melody'); is $author->name, 'Melody'; $author->email('melody@nelson.com'); $author->url('http://www.melodynelson.com/'); $entry3->title('Histoire'); ok !$entry3->author; $entry3->author($author); isa_ok $entry3->author, 'XML::Atom::Person'; is $entry3->author->name, 'Melody'; $entry = XML::Atom::Entry->new; $entry->content('

Not well-formed.'); is $entry->content->mode, 'escaped'; is $entry->content->body, '

Not well-formed.'; $entry = XML::Atom::Entry->new( Stream => \$entry->as_xml ); is $entry->content->mode, 'escaped'; is $entry->content->body, '

Not well-formed.'; $entry = XML::Atom::Entry->new; $entry->content("This is a test that should use base64\0."); $entry->content->type('image/gif'); is $entry->content->mode, 'base64'; is $entry->content->body, "This is a test that should use base64\0."; is $entry->content->type, 'image/gif'; $entry = XML::Atom::Entry->new( Stream => \$entry->as_xml ); is $entry->content->mode, 'base64'; is $entry->content->body, "This is a test that should use base64\0."; is $entry->content->type, 'image/gif'; my $ns = XML::Atom::Namespace->new(list => "http://www.sixapart.com/atom/list#"); $link->set($ns, type => "Books"); $entry->add_link($link); $xml = $entry->as_xml; like $xml, qr/list:type="Books"/; $entry->set($dc, "subject" => "Weblog"); like $entry->as_xml, qr/Weblog<\/dc:subject>/; $entry->add($dc, "subject" => "Tech"); like $entry->as_xml, qr/Weblog<\/dc:subject>/; like $entry->as_xml, qr/Tech<\/dc:subject>/; # re-set $entry->set($dc, "subject" => "Weblog"); like $entry->as_xml, qr/Weblog<\/dc:subject>/; # euc-jp feed SKIP: { skip "Skipping UTF-8 tests since it depends on libxml", 2; $entry = XML::Atom::Entry->new('t/samples/entry-euc.xml'); is $entry->title, 'ゲストオーサー'; is $entry->content->body, '

日本語のフィード

'; } XML-Atom-0.41/t/12-feed.t000644 000771 000024 00000004170 11174274617 015522 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 33; use XML::Atom::Feed; use URI; my $feed; $feed = XML::Atom::Feed->new('t/samples/feed.xml'); isa_ok $feed, 'XML::Atom::Feed'; is $feed->title, 'dive into atom'; is ref($feed->link), 'XML::Atom::Link'; is $feed->link->href, 'http://diveintomark.org/atom/'; is $feed->version, '0.2'; is $feed->language, 'en'; is $feed->modified, '2003-08-25T11:39:42Z'; is $feed->tagline, ''; is $feed->id, 'tag:diveintomark.org,2003:14'; is $feed->generator, 'http://www.movabletype.org/?v=2.64'; is $feed->copyright, 'Copyright (c) 2003, Atom User'; isa_ok $feed->author, 'XML::Atom::Person'; is $feed->author->name, 'Atom User'; is $feed->author->email, 'atom@example.com'; is $feed->author->homepage, 'http://diveintomark.org/atom/'; $feed->version('0.3'); is $feed->version, '0.3'; $feed->language('fr'); is $feed->language, 'fr'; my @entries = $feed->entries; is scalar(@entries), 15; my $entry = $entries[0]; is ref($entry), 'XML::Atom::Entry'; is $entry->title, 'Test'; is $entry->content->body, '

Python is cool stuff for ReSTy webapps.

'; $entry = XML::Atom::Entry->new; $entry->title('Foo'); $entry->content('

This is a test.

'); $feed->add_entry($entry); @entries = $feed->entries; is scalar @entries, 16; my $last = $entries[-1]; is $last->title, 'Foo'; #ok($last->content->body, '

This is a test.

'); $feed->add_link({ title => 'Number Three', rel => 'service.post', href => 'http://www.example.com/atom', type => 'application/x.atom+xml' }); my @links = $feed->link; is scalar @links, 2; is ref($links[-1]), 'XML::Atom::Link'; is $links[-1]->title, 'Number Three'; is $links[-1]->rel, 'service.post'; is $links[-1]->href, 'http://www.example.com/atom'; is $links[-1]->type, 'application/x.atom+xml'; # Test we can insert an entry in the front. $entry = XML::Atom::Entry->new; $entry->title('Bar'); $entry->content('

This is another test.

'); $feed->add_entry($entry, { mode => 'insert' }); @entries = $feed->entries; is scalar @entries, 17; is $entries[0]->title, 'Bar'; is $feed->title, 'dive into atom'; is $feed->content_type, "application/x.atom+xml"; XML-Atom-0.41/t/13-atom1.t000644 000771 000024 00000004035 11174274617 015641 0ustar00miyagawastaff000000 000000 use strict; use Test::More tests => 23; use XML::Atom::Feed; sub is_deeply_method; my $file = "t/samples/atom-1.0.xml"; open my $fh, $file or die "$file: $!"; my $feed = XML::Atom::Feed->new(Stream => $fh); isa_ok $feed, 'XML::Atom::Feed'; is $feed->title, 'dive into mark', 'atom:title'; is $feed->version, '1.0', 'atom:version based on namespace'; is $feed->updated, "2005-07-11T12:29:29Z", 'atom:updated'; my @link = $feed->link; is @link, 2, "2 links"; is_deeply_method $link[0], { rel => 'alternate', type => 'text/html', hreflang => 'en', href => 'http://example.org/' }; is_deeply_method $link[1], { rel => 'self', type => 'application/atom+xml', href => 'http://example.org/feed.atom' }; my @entry = $feed->entries; is @entry, 1, "1 entry"; my $entry = $entry[0]; is $entry->title, 'Atom draft-07 snapshot'; my @entry_link = $entry->link; is_deeply_method $entry_link[0], { rel => 'alternate', type => 'text/html', href => 'http://example.org/2005/04/02/atom' }; is_deeply_method $entry_link[1], { rel => 'enclosure', type => 'audio/mpeg', length => 1337, href => 'http://example.org/audio/ph34r_my_podcast.mp3' }; is $entry->author->name, 'Mark Pilgrim'; is $entry->author->uri, 'http://example.org/'; is $entry->author->email, 'f8dy@example.com'; my @contrib = $entry->contributor; is @contrib, 2, "2 contribs"; is_deeply_method $contrib[0], { name => 'Sam Ruby' }; is_deeply_method $contrib[1], { name => 'Joe Gregorio' }; @contrib = $entry->contributors; is @contrib, 2, "2 contribs (moniker)"; is_deeply_method $contrib[0], { name => 'Sam Ruby' }; is_deeply_method $contrib[1], { name => 'Joe Gregorio' }; my $contrib = $entry->contributor; is $contrib->name, 'Sam Ruby', 'testing scalar context'; is_deeply_method $entry->content, { type => 'xhtml', lang => 'en', base => 'http://diveintomark.org/' }; like $entry->content->body, qr!

.*\[Update: The Atom draft is finished.\].*

!s; sub is_deeply_method { my($thing, $hashref, $msg) = @_; my %copy = map { $_ => $thing->$_ } keys %$hashref; is_deeply \%copy, $hashref, $msg; } XML-Atom-0.41/t/14-atom1-create.t000644 000771 000024 00000002366 11174274617 017110 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use XML::Atom; use XML::Atom::Feed; use XML::Atom::Link; use Test::More tests => 10; my $feed = XML::Atom::Feed->new(Version => 1.0); $feed->title("foo bar"); my $link = XML::Atom::Link->new(Version => 1.0); $link->href("http://www.example.com/"); my $entry = XML::Atom::Entry->new(Version => 1.0); $entry->title("Foo Bar"); $entry->content("foo bar"); $feed->add_link($link); $feed->add_entry($entry); like $feed->as_xml, qr!as_xml, qr!mode="xml"!; like $feed->as_xml, qr!type="xhtml"!; # usage of DefaultVersion $XML::Atom::DefaultVersion = 1.0; $feed = XML::Atom::Feed->new; $feed->title("foo bar"); $feed->add_link({ href => "http://www.example.com/" }); $entry = XML::Atom::Entry->new( Version => "1.0" ); $entry->title("Foo Bar"); $entry->content("foo bar"); $feed->add_entry($entry); like $feed->as_xml, qr!as_xml, qr!mode="xml"!; like $feed->as_xml, qr!type="xhtml"!; # parse again my $xml = $feed->as_xml; $feed = XML::Atom::Feed->new(Stream => \$xml); is $feed->version, "1.0"; is $feed->title, "foo bar"; is $feed->link->href, 'http://www.example.com/'; is $feed->content_type, "application/atom+xml"; XML-Atom-0.41/t/15-content-image.t000644 000771 000024 00000000544 11174274617 017355 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 2; use Encode; use XML::Atom::Entry; my $file = "t/samples/lifeblog-atom.xml"; my $xml = slurp($file); my $entry = XML::Atom::Entry->new(Stream => \$xml); ok $entry; ok !Encode::is_utf8($entry->content->body); sub slurp { my $file = shift; open my$fh, $file or die $!; local $/; <$fh>; } XML-Atom-0.41/t/16-content-binary.t000644 000771 000024 00000000517 11174274617 017560 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use Test::More tests => 1; use Encode; use XML::Atom::Entry; my $file = "t/samples/me.jpg"; my $data = slurp($file); my $entry = XML::Atom::Entry->new; $entry->content($data); ok( $data eq $entry->content->body ); sub slurp { my $file = shift; open my$fh, $file or die $!; local $/; <$fh>; } XML-Atom-0.41/t/17-renames.t000644 000771 000024 00000000643 11174274617 016257 0ustar00miyagawastaff000000 000000 use strict; use FindBin; use Test::More tests => 5; use XML::Atom::Feed; my $f = XML::Atom::Feed->new("$FindBin::Bin/samples/atom-1.0.xml"); is $f->tagline, $f->subtitle; my $e = ($f->entries)[0]; is $e->modified, $e->updated, $e->modified; is $e->issued, $e->published, $e->issued; # create $f = XML::Atom::Feed->new; $f->title("foo bar"); $f->tagline("Hello"); is $f->tagline, "Hello"; is $f->subtitle, "Hello"; XML-Atom-0.41/t/18-unicode.t000644 000771 000024 00000001601 11174274617 016247 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use encoding "utf-8"; use Test::More skip_all => "Skipping Unicode test since it depends on LibXML"; use XML::Atom; use XML::Atom::Entry; use XML::Atom::Person; $XML::Atom::ForceUnicode = 1; my $entry; $entry = XML::Atom::Entry->new('t/samples/entry-utf8.xml'); ok $entry; ok utf8::is_utf8($entry->title); ok utf8::is_utf8($entry->summary); ok utf8::is_utf8($entry->author->name); is $entry->title, "フーバー"; is $entry->summary, "これはサマリ"; is $entry->author->name, "ミナ"; my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/'); my @cat = $entry->getlist($dc, 'subject'); ok utf8::is_utf8($cat[0]); ok utf8::is_utf8($cat[1]); is $cat[0], "たべもの"; is $cat[1], "猫"; is $entry->content->type, 'text/html'; ok utf8::is_utf8($entry->content->body); is $entry->content->body, "

これは日本語のポストです。

"; XML-Atom-0.41/t/19-ext.t000644 000771 000024 00000004015 11174274617 015424 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use FindBin; use Test::More tests => 16; use XML::Atom::Feed; my $foo = XML::Atom::Ext::Foo->new; isa_ok $foo, 'XML::Atom::Ext::Foo'; $foo->bar(1); is $foo->bar, 1; like $foo->as_xml, qr//; like $foo->as_xml, qr/1<\/bar>/; my $feed = XML::Atom::Feed->new; $feed->foo($foo); my $foo2 = $feed->foo; isa_ok $foo2, 'XML::Atom::Ext::Foo'; is $foo2->bar, 1; ## Make sure the alternate name works. $feed->foo2($foo); $foo2 = $feed->foo2; isa_ok $foo2, 'XML::Atom::Ext::Foo'; is $foo2->bar, 1; like $feed->as_xml, qr//; { my $elem = XML::Atom::Ext::WithNS->new; isa_ok $elem, 'XML::Atom::Ext::WithNS'; $elem->baz(1); is $elem->baz, 1; like $elem->as_xml, qr{add_with_ns( $elem ); like $feed->as_xml, qr{new( \' ' ); my( @elems ) = $feed->with_ns; is scalar @elems, 1; isa_ok $elems[ 0 ], 'XML::Atom::Ext::WithNS'; is $elems[ 0 ]->baz, 1 ; } package XML::Atom::Ext::Foo; use strict; use base qw( XML::Atom::Base ); BEGIN { __PACKAGE__->mk_elem_accessors('bar'); XML::Atom::Feed->mk_object_accessor( foo => __PACKAGE__ ); XML::Atom::Feed->mk_object_accessor( foo2 => __PACKAGE__ ); } sub element_name { 'foo' } sub element_ns { 'http://www.example.com/ns/' } package XML::Atom::Ext::WithNS; use strict; use warnings; use base qw( XML::Atom::Base ); BEGIN { __PACKAGE__->mk_attr_accessors( 'baz' ); XML::Atom::Feed->mk_object_list_accessor( with_ns => __PACKAGE__ ); } sub element_name { return 'with_ns' } sub element_ns { return XML::Atom::Namespace->new( "withns" => q{http://example.com/withns/} ); } XML-Atom-0.41/t/20-content-xhtml.t000644 000771 000024 00000000747 11174274617 017430 0ustar00miyagawastaff000000 000000 # $Id$ use strict; use XML::Atom; use XML::Atom::Entry; use XML::Atom::Feed; use Test::More tests => 2; my $entry = XML::Atom::Entry->new; $entry->content('Bold'); unlike $entry->as_xml, qr/new; $entry = XML::Atom::Entry->new; $entry->content('Bold'); $feed->add_entry($entry); unlike $feed->as_xml, qr/new("t/samples/vox.xml"); my $entry = ($feed->entries)[0]; ok $entry; is $entry->title, "Pirates of Caribbean - Dead Man's Chest"; my @category = $entry->category; is @category, 4, 'returns list in a list context'; is $category[0]->term, 'disney'; is $category[0]->scheme, 'http://bulknews.vox.com/tags/disney/'; is $category[0]->label, 'disney'; my $cat = $entry->category; isa_ok $cat, 'XML::Atom::Category', 'scalar context'; is $cat->term, 'disney'; my @categories = $entry->categories; is @categories, 4, "moniker"; { my $entry = XML::Atom::Entry->new( Version => 1.0 ); $entry->title("foo bar"); $entry->add_category({ term => "foo", scheme => "http://example.org/foo#", label => "foo bar", }); my @cat = $entry->categories; is @cat, 1; is $cat[0]->term, "foo"; is $cat[0]->scheme, "http://example.org/foo#"; is $cat[0]->label, "foo bar"; $entry->add_category({ term => "bar", scheme => "http://example.org/bar#", }); @cat = $entry->categories; is @cat, 2; is $cat[1]->term, "bar"; my $xml = $entry->as_xml; like $xml, qr!!; like $xml, qr!!; } XML-Atom-0.41/t/24-bad-content.t000644 000771 000024 00000000600 11174274617 017012 0ustar00miyagawastaff000000 000000 use strict; use Test::More tests => 2; use XML::Atom::Content; my $stuff = "\x{1234}"; { my $content = XML::Atom::Content->new(Version => 0.3); $content->body($stuff); isnt $content->mode, 'base64'; } { my $content = XML::Atom::Content->new(Version => 0.3); eval { doo(); }; # this set $@ $content->body($stuff); isnt $content->mode, 'base64'; } XML-Atom-0.41/t/25-utf8-create.t000644 000771 000024 00000000664 11174274617 016756 0ustar00miyagawastaff000000 000000 use strict; use Test::More 'no_plan'; use FindBin; use XML::Atom::Feed; my $feed = XML::Atom::Feed->new(Version => 1.0); $feed->version; # 1.0 $feed->title("Dicion\xc3\xa1rios"); is $feed->title, "Dicion\xc3\xa1rios"; my $out = "$FindBin::Bin/utf8-create.xml"; open my $fh, ">", $out; print $fh $feed->as_xml_utf8; close $fh; $feed = XML::Atom::Feed->new($out); is $feed->title, "Dicion\xc3\xa1rios"; END { unlink $out if -e $out } XML-Atom-0.41/t/27-client-leaks.t000644 000771 000024 00000000640 11174274617 017176 0ustar00miyagawastaff000000 000000 use strict; use warnings; use Test::More; BEGIN { unless (eval { require DateTime }) { plan skip_all => 'DateTime is required for tests'; } } plan tests => 1; use XML::Atom::Client; my $foo; no warnings 'redefine'; my $orig = LWP::UserAgent::AtomClient->can('DESTROY'); *LWP::UserAgent::AtomClient::DESTROY = sub { $orig->(@_); $foo = 1 }; { my $client = XML::Atom::Client->new; }; ok $foo; XML-Atom-0.41/t/28-ext.t000644 000771 000024 00000004614 11174274617 015431 0ustar00miyagawastaff000000 000000 package XML::Atom::Ext::Test; use base qw( XML::Atom::Base ); XML::Atom::Feed->mk_elem_accessors(qw(totalResults startIndex itemsPerPage), [ element_ns() ] ); XML::Atom::Feed->mk_object_list_accessor( ext_link => 'XML::Atom::Ext::Test::Link' ); #XML::Atom::Feed->mk_object_accessor( Query => 'XML::Atom::Ext::::Query' ); sub element_ns { return XML::Atom::Namespace->new("testext" => q{http://test.com/-/spec/test/0.1/} ); } 1; package XML::Atom::Ext::Test::Link; use base qw( XML::Atom::Base ); __PACKAGE__->mk_attr_accessors( qw( href hreflang rel type ) ); sub element_name { return 'link' } sub element_ns { return XML::Atom::Ext::Test->element_ns; } 1; package main; use strict; use warnings; use XML::Atom::Feed; use Test::More tests => 8; my $feed = XML::Atom::Feed->new; my $link = XML::Atom::Link->new; $link->href(q{http://www.legacy_link.com}); $feed->add_link($link); my $ext_link = XML::Atom::Ext::Test::Link->new; $ext_link->href(q{http://www.extended_link.org}); $feed->add_ext_link($ext_link); ok($ext_link, "creating extension link"); # Test simple accessors my @accessors = qw( totalResults startIndex itemsPerPage ); for ( @accessors ) { $feed->$_( 2 ); } for ( @accessors ) { is($feed->$_, 2, "extension accessors"); } my $xml = $feed->as_xml; like( $xml, qr{xmlns:testext="http://test.com/-/spec/test/0.1/"}, "ext namespace"); like( $xml, qr{}, "ext link match"); like( $xml, qr{2}, "ext method match"); like( $xml, qr{}, "standard link match"); __END__ =head2 Expected Output 2 2 2 XML-Atom-0.41/t/29-source.t000644 000771 000024 00000001215 11316264777 016130 0ustar00miyagawastaff000000 000000 use strict; use Test::More tests => 9; use XML::Atom::Feed; my $feed = XML::Atom::Feed->new("t/samples/source.xml"); my $entry = ($feed->entries)[0]; ok $entry; is $entry->title, "Example Entry"; ok $entry->source; is $entry->source->title, "Frank's JiveBlog"; $entry->title("Altered Entry"); is $entry->title, "Altered Entry"; my $link = $entry->source->link; is $link->rel, 'alternate'; is $link->type, 'text/html'; is $link->href, 'http://jiveblog.example.com/frank'; my $new_source = XML::Atom::Feed->new(Version => 1.0); $new_source->title("Jank's FriveBlog"); $entry->source($new_source); is $entry->source->title, "Jank's FriveBlog"; XML-Atom-0.41/t/30-datetime-stringification.t000644 000771 000024 00000001044 11635444454 021602 0ustar00miyagawastaff000000 000000 use strict; use warnings; use Test::More; BEGIN { unless (eval { require DateTime } and eval { require DateTime::Format::Atom }) { plan skip_all => 'DateTime and DateTime::Format::Atom are required for tests'; } } plan tests => 2; use XML::Atom::Feed; my $f = XML::Atom::Feed->new(); my $dt = DateTime->now(); $f->updated($dt); my $xml = $f->as_xml; my $dt_string = DateTime::Format::Atom->format_datetime($dt); like($xml, qr/$dt_string/, "correct format made"); unlike($xml, qr||, "no empty modified elements"); XML-Atom-0.41/t/31-external-entities-libxml.t000644 000771 000024 00000003763 11635444454 021560 0ustar00miyagawastaff000000 000000 use strict; use Test::More; use XML::Atom::Entry; use FindBin; my $filepath = "$FindBin::Bin/samples/entry-ns.xml"; $filepath = "/$filepath" if $filepath !~ m@^/@; BEGIN { unless (eval { require XML::LibXML }) { plan skip_all => 'LibXML required for this test'; } } plan tests => 4; my $xml = <<"EOX"; ]> Guest Author tag:typepad.com:post:75207 2003-07-21T02:47:34-07:00 2003-08-22T18:36:57-07:00 2003-07-21T02:47:34-07:00 No, Ben isn't updating. It's me testing out guest author functionality.... Mena http://mena.typepad.com/ Food Cats &ref;

No, Ben isn't updating. It's me testing out guest author functionality.

 EOX ## default sane parser { my $entry = XML::Atom::Entry->new(Stream => \$xml); is $entry->title, "Guest Author", "got title"; my $content = $entry->content->body; unlike $content, qr/This is what you get when you do unit testing/, "ignored entity"; } ## custom parser { my $libxml = XML::LibXML->new; my $entry = XML::Atom::Entry->new(Stream => \$xml, Parser => $libxml); is $entry->title, "Guest Author", "got title"; my $content = $entry->content->body; like $content, qr/This is what you get when you do unit testing/, "resolved entity"; } XML-Atom-0.41/t/31-external-entities-xpath.t000644 000771 000024 00000004346 11573771006 021410 0ustar00miyagawastaff000000 000000 use strict; use Test::More; BEGIN { unless (eval { require XML::XPath }) { plan skip_all => 'XML::XPath required for this test'; } } plan tests => 4; BEGIN { ## hardcore, because XML::Atom doesn't make it easy to change it at ## runtime require XML::Atom; if (XML::Atom->LIBXML) { no strict 'refs'; diag "XPath Override in place"; *{XML::Atom::LIBXML} = sub() {0}; } } use XML::Parser; use XML::Atom::Entry; use FindBin; my $filepath = "$FindBin::Bin/samples/entry-ns.xml"; my $xml = <<"EOX"; ]> Guest Author tag:typepad.com:post:75207 2003-07-21T02:47:34-07:00 2003-08-22T18:36:57-07:00 2003-07-21T02:47:34-07:00 No, Ben isn't updating. It's me testing out guest author functionality.... Mena http://mena.typepad.com/ Food Cats &ref;

No, Ben isn't updating. It's me testing out guest author functionality.

 EOX ## Sane default { my $entry = XML::Atom::Entry->new(Stream => \$xml); is $entry->title, "Guest Author", "got title"; my $content = $entry->content->body; unlike $content, qr/This is what you get when you do unit testing/, "ignored entity"; } ## custom parser { my $parser = XML::Parser->new(); # no option my $entry = XML::Atom::Entry->new(Stream => \$xml, Parser => $parser); is $entry->title, "Guest Author", "got title"; my $content = $entry->content->body; like $content, qr/This is what you get when you do unit testing/, "resolved entity"; } XML-Atom-0.41/t/samples/000755 000771 000024 00000000000 11640225176 015646 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/t/TestLib.pm000644 000771 000024 00000000664 11174274617 016122 0ustar00miyagawastaff000000 000000 package t::TestLib; use strict; use base qw( Exporter ); our @EXPORT = qw( xmllib_support_encoding ); use XML::Atom; sub xmllib_support_encoding { my $enc = shift; my $xml = qq(\n); if (LIBXML) { eval { XML::LibXML->new->parse_string($xml) }; return $@ ? 0 : 1; } else { eval { XML::XPath->new(xml => $xml) }; return $@ ? 0 : 1; } } 1; XML-Atom-0.41/t/samples/atom-1.0.xml000644 000771 000024 00000003215 11174274617 017633 0ustar00miyagawastaff000000 000000 dive into mark A <em>lot</em> of effort went into making this effortless 2005-07-11T12:29:29Z tag:example.org,2003:3 Copyright (c) 2003, Mark Pilgrim Example Toolkit Atom draft-07 snapshot tag:example.org,2003:3.2397 2005-07-11T12:29:29Z 2003-12-13T08:29:29-04:00 Mark Pilgrim http://example.org/ f8dy@example.com Sam Ruby Joe Gregorio

[Update: The Atom draft is finished.]

 XML-Atom-0.41/t/samples/entry-euc.xml000644 000771 000024 00000001745 11174274617 020320 0ustar00miyagawastaff000000 000000 ȥ tag:typepad.com:post:75207 2003-07-21T02:47:34-07:00 2003-08-22T18:36:57-07:00 2003-07-21T02:47:34-07:00 No, Ben isn't updating. It's me testing out guest author functionality.... Mena http://mena.typepad.com/ Food Cats

ܸΥե

 XML-Atom-0.41/t/samples/entry-full.xml000644 000771 000024 00000002031 11174274617 020473 0ustar00miyagawastaff000000 000000 Guest Author tag:typepad.com:post:75207 2003-07-21T02:47:34-07:00 2003-08-22T18:36:57-07:00 2003-07-21T02:47:34-07:00 No, Ben isn't updating. It's me testing out guest author functionality.... Mena http://mena.typepad.com/ Food Cats

No, Ben isn't updating. It's me testing out guest author functionality.

 XML-Atom-0.41/t/samples/entry-ns.xml000644 000771 000024 00000000541 11174274617 020155 0ustar00miyagawastaff000000 000000 Unit Test 1
This is what you get when you do unit testing.
 XML-Atom-0.41/t/samples/entry-utf8.xml000644 000771 000024 00000001700 11174274617 020421 0ustar00miyagawastaff000000 000000 フーバー tag:typepad.com:post:75207 2003-07-21T02:47:34-07:00 2003-08-22T18:36:57-07:00 2003-07-21T02:47:34-07:00 これはサマリ ミナ http://mena.typepad.com/ たべもの 猫

これは日本語のポストです。

 XML-Atom-0.41/t/samples/feed.xml000644 000771 000024 00000024200 11174274617 017277 0ustar00miyagawastaff000000 000000 dive into atom 2003-08-25T11:39:42Z Atom User http://diveintomark.org/atom/ atom@example.com tag:diveintomark.org,2003:14 http://www.movabletype.org/?v=2.64 Copyright (c) 2003, Atom User Test tag:diveintomark.org,2003:14.2447 2003-08-25T07:39:42-05:00 2003-08-25T12:10:42Z Well, it's about testing, really. 2003-08-25T11:39:42Z

Python is cool stuff for ReSTy webapps.

 Created using the Fix Auth tag:diveintomark.org,2003:14.2444 2003-08-25T04:04:26-05:00 2003-08-25T08:04:26Z Stuff.... 2003-08-25T08:04:26Z Stuff. just a test - updated tag:diveintomark.org,2003:14.2441 2003-08-24T00:08:37-05:00 2003-08-25T16:48:49Z rubys 2003-08-24T04:08:37Z nothing to see here, move along Second attempt. tag:diveintomark.org,2003:14.2440 2003-08-22T21:28:17-05:00 2003-08-23T01:40:03Z Updating now works too. How about a new paragraph?... 2003-08-23T01:28:17Z Updating now works too.

How about a new paragraph?

]]> First post. tag:diveintomark.org,2003:14.2439 2003-08-22T21:17:21-05:00 2003-08-25T11:40:02Z Testing a javascript client. Test. Again. and again.... 2003-08-23T01:17:21Z javascript client. Test. Again. and again.]]> Can anyone post? tag:diveintomark.org,2003:14.2437 2003-08-20T12:11:55-05:00 2003-08-25T08:03:41Z (not) Mark tries to make a post 2003-08-20T16:11:55Z It works! Yes! for now]]> Unit Test 1 tag:diveintomark.org,2003:14.2431 2003-08-18T15:21:06-05:00 2003-08-18T19:21:06Z This is what you get 2003-08-18T19:21:06Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2430 2003-08-18T15:18:54-05:00 2003-08-18T19:18:54Z This is what you get 2003-08-18T19:18:54Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2427 2003-08-18T15:13:11-05:00 2003-08-18T19:13:11Z This is what you get 2003-08-18T19:13:11Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2426 2003-08-18T15:12:31-05:00 2003-08-18T19:12:31Z This is what you get 2003-08-18T19:12:31Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2425 2003-08-18T15:11:56-05:00 2003-08-18T19:11:56Z This is what you get 2003-08-18T19:11:56Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2424 2003-08-18T15:11:21-05:00 2003-08-18T19:11:21Z This is what you get 2003-08-18T19:11:21Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2423 2003-08-18T15:10:50-05:00 2003-08-18T19:10:50Z This is what you get 2003-08-18T19:10:50Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2421 2003-08-18T15:07:58-05:00 2003-08-18T19:07:58Z This is what you get 2003-08-18T19:07:58Z When you do unit testing. Unit Test 1 tag:diveintomark.org,2003:14.2420 2003-08-18T14:59:24-05:00 2003-08-18T18:59:24Z This is what you get 2003-08-18T18:59:24Z When you do unit testing. XML-Atom-0.41/t/samples/lifeblog-atom.xml000644 000771 000024 00000017441 11174274617 021126 0ustar00miyagawastaff000000 000000 me.jpg /9j/4AAQSkZJRgABAgEASABIAAD/7QE0UGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEAAgBIAAAAAQACOEJJTQPzAAAAAAAIAAAAAAAAAAA4QklNJxAAAAAAAAoAAQAAAAAAAAACOEJJTQP1AAAAAABIAC9mZgABAGxmZgAGAAAAAAABAC9mZgABAKGZmgAGAAAAAAABADIAAAABAFoAAAAGAAAAAAABADUAAAABAC0AAAAGAAAAAAABOEJJTQP4AAAAAABwAAD/////////////////////////////A+gAAAAA/////////////////////////////wPoAAAAAP////////////////////////////8D6AAAAAD/////////////////////////////A+gAADhCSU0EBgAAAAAAAgAC/+4ADkFkb2JlAGSAAAAAAf/bAIQADAgICAkIDAkJDBELCgsRFQ8MDA8VGBMTFRMTGBEMDAwMDAwRDAwMDAwMDAwMDAwMDAwMDAwMDAwMDAwMDAwMDAENCwsNDg0QDg4QFA4ODhQUDg4ODhQRDAwMDAwREQwMDAwMDBEMDAwMDAwMDAwMDAwMDAwMDAwMDAwMDAwMDAwM/8AAEQgAyACWAwEiAAIRAQMRAf/EAT8AAAEFAQEBAQEBAAAAAAAAAAMAAQIEBQYHCAkKCwEAAQUBAQEBAQEAAAAAAAAAAQACAwQFBgcICQoLEAABBAEDAgQCBQcGCAUDDDMBAAIRAwQhEjEFQVFhEyJxgTIGFJGhsUIjJBVSwWIzNHKC0UMHJZJT8OHxY3M1FqKygyZEk1RkRcKjdDYX0lXiZfKzhMPTdePzRieUpIW0lcTU5PSltcXV5fVWZnaGlqa2xtbm9jdHV2d3h5ent8fX5/cRAAICAQIEBAMEBQYHBwYFNQEAAhEDITESBEFRYXEiEwUygZEUobFCI8FS0fAzJGLhcoKSQ1MVY3M08SUGFqKygwcmNcLSRJNUoxdkRVU2dGXi8rOEw9N14/NGlKSFtJXE1OT0pbXF1eX1VmZ2hpamtsbW5vYnN0dXZ3eHl6e3x//dAAQACv/aAAwDAQACEQMRAD8A8qSSSSUpJJJJSkkkklKSSSSUpJJJJSkkkklKSSSSUpJJJJSkkkklKSSSSU//0PKkkkklKSSSSUpJJJJSkkkklKSTgSQPFdrR9QK8vGece1/2iuoWbTEGfL+sosufHiMRM1x7aXszYeXnl4uCvTV8R4fmeJSRL6LKLXVWCHtMFDUoN6hilExJjIVKJog9CFJJJJIUkkkkpSSltThqkjhkeiLYJKe1JO+7yVb/AP/R8qSSSSUpJJJJSkklJjXPcGtEkmABqSkoLEEfNMtPrONVjGitv09gNgHAJ/NWaU2EhKIkOrJmx+3Mxu6rXzb3RMT7Z1THp/NLgXfAe4r2LoF9OPVldUvYW4mPNLrDA1YWud7f/A1w3+LbLw8U5j8nCZkNgbrnctDWus2tn2/Sb9P6a6b68W14P+Leiuqa3dQurcQOSbC/Nfu/zVTz4xl5iPqHoFAfuy8W1jye1y1GBrJIEyvh4of1f8V8x67ay7ql72aNLuFnpySdTqmVyMeGIj2FNXPl93LPJVe5IzrtxKSSSTmNdSa1M0IjWlW+XwGRGi0lfYRGnPCPVhW2CQODBV/pnTXZjwXA9gyOIXZ9P+r7Gt2msGYn4hagwwgPU1p5zdRGvV4Q9Kv2g7eyS9O/5ua7PR1iTp/ahJHiw+DH7uTv1p//0vKkkkSqwVulzQ8EEFp41Ef9H6SSkaStdQzK8zI9arFqw27Wt9KjcGS0Rv8A0jrHb3/nqsElL1sfY9tbBue4w0eJK6P6sY+LRkX15tTmZbXBtb5A9OP5x2vtd+asrpN2DV1fEtyazZiMtabqiJ3NB9zI/lrosS7afsuFjNfnw50HXZu2bTO5rW/R/wDUabmjeOWtM3LH9bHS93Qr+qlXWW2uc/0ySQx45mfauW6z0Wzp1jsbJIZk0xD/AMy5hMNfW7/SM3fpGr1Ho7msxwLAG2Aw8N4kcrnfrszHvodVt3E7RTGrg8kNaG/1lVxT4REXpbezw9wy2uknSPq1kdG+rd99tlNj8ppgVu3RI3Dc5E/xu2+h0joPT+CGue4f1GVVN/6tyudKxQ/pjcZodcGuDL5BhrgGVta+fztjFofXfpePnfWXpgyQLKacTJcaHFrQ/Tb7LHu9j2yz3Pr9Ov8AnPUTOXPFlyZOEjY69bDFzUSI48fEJcJkPT0EeGMXxNJOmV9oKThMpDVOgLIUyaFdwKi+2QzfsgxyOY1VRoW30/HdVmso0srcG2tAPO9gc33fyNy2eVAAYMpPCaey+r3ThbYHen6ZcRDfAL0Tp3TKseoSACdToFzv1Uw2NpqsjUOLXfcHtXYxLwOwEhVOezkkQB0G7Fhx3rLXX82PoVbpjXxSRUlQ4j3bPtx7Du//0/Kk4EkDxTJJKbedhfY3sqcT6+1ptqPLXODXgafyXqvZVZXG9paHatJGhHEtT1N9S5jXv2hzgC89ge6nlW3vcKrbDYKfazWQB/I/kpKQroPqv1PAwHP+1OcDYfzQueTpuSAnHhJI8mTDlOOfEBb6Hk/WKhrduE11k9+B8Ssd/UurjrGHnMBDd7WMqHvlwl0+l+eqH1ftreXV2SSOB4wt3FNo6k/LYzfR0qoWOHhZefSrIb+9sP8AYVOMTHIYgXQO7pzlGeATJriqq8/lL2OHc+i+hmLmPsbnXtfkVFrmt3vLXW+myz3V1/T9m7/qFz/+Mr642M63d0uhjX1UYtmO5xMjfktrNr9sfSqp/RrfxbOnXY7eoX9Qo6Y6yrfi2XOaA0uBay0VWOZ6n/kP+MXM9I/xW9Y61n5OX1fLDaHvc4ZVRFhvLveL6/zfSfO5SctDJK8k9Iy+WB/RDR5kwEhGG8R6pfvSL52ku++tX+KbqnSq/tfSHu6ljNE2V7QLmxy5tbf55n/F/pP+DXFZGFlYtVT8imyn1gXV+owtDmjTewu+l7lbprNdXG42PbWwYjrbMlxANBr5hpfdYx7HO9rXj2s2/Q/SL0f/ABY/VX6sda+rmRZnY7MnMdc6u1ziQ+toDTV6W0/ov3t64rruI/6ufWPJ6bXdYasK0ml1btjoewFrtw3bLHVua21PxECXiNR2Rbjhei/4t6un/tWm7K9N7jT6dTXe4NMbt7t/530mLzkK3iZj8dzXsc5r28OaYMeC1JQllwyhGXATR/8AQVsZRjISkDIajTf1fpD+6+85luJh9QDKS1vqbXuY2IBkjt9Hctqq1lrQ5h1AXivS/rA51gNhiY7ydF2fT/rKWtEPBCZl+HZPbhrcwNWrLmKyyoeknrodHutZ7fBJct/znM8hJVfuObsv+9R8ftf/1PKkR7DW0Bwh7oMeAIlv+cmqZvfBkNGryOzR9IprH73l0QDwPLskpikkkkpSSSSSnd+qPS8vq3UThYYnIe0FhOjRB973n9xrV0vVNn1et6kzHH2ppsONbv0FjW1V03h3p7Xs/Sut9L/Rr0T6pfVXofQ8SnJwaNuRfSwWXuJc9wI9V3P0fd+4vLuo3nOdTfukZmdZZY3xabn2t9qjnERJn1/ZFtY8kpQGP9GOn+HNli9Fv+tH1sxOkhsYfT6a2ZDm6hlVTWh/9u2PTavcK62V1tYwbWtADWjsAuM/xY9JfRgZvV7hFnVby6uf9DUXV1O/6482uXbJ2McMIjwYMhucj4sHiW/DX7l5R/jl6Le1+J1akOOMA6m9kksre4+pXY1n5nrzZv8A+EXrJGiyev8AS29Z6JmdPeNz7Kn1gH9+N1Tv+3BXYpAL3YySNvq/PXSut9W6Pa63pmVZivsG15rPI/lNPtVbIyL8m9+RkWOuutcXWWPJc5xPLnOKjbVZTa+mwFtlbix7TyHNO1wUENimgzDlNpQgVd6VhN6hl/Z35FWI3Y95uuJDfY0v2+0OdvfG1iucvzNEWtIYsvczVphX8brORUeVlOgEgHc0cEd0g5aMOe1qVFilhjLcPTt63mOa8hpJY0OdzIBjXaksgdTy/txzTeRlbIFoI19vo+7/AKwknfefAf8AoXb+6xfd4v8A/9Xy+dlJHBt5/qg8H+0hKT3F7i49+wUUlKSSSSUpbn1d6FVmst6jnWijpuG9jbXnUve8+ylv/VWLDXqeXgY+B/i0xhsDTZi13OgTNuRax+9x/wCKGxEdT2FrsYBnEHqadfq31iuy6qOm4JfTW3GdkZD/AKO5hjGx6W/yXep6rlyXUKPX+tWNgAbfRAa0ARG5rWsOn8q9dVi4rLsvHAbrmdOrZRb+bvpd6np/1nbmJdd6I7MtxutdNaG9SFYoe1x2gvrPqU7v3XuuZ6KpHJKZl/WHCO3qdAwhDhiNAJcZO5p7fpQpbgU1UgNZQ30do7Gv9G5v/RVxcx9XusU3Ybeo11PZTkDdlMM7q7Geyxzm/wAjbssXTAggEGQdQVahLiHj1aGSBjIj7F0N0NdPZ2h+PZTnUhM9oc0t4nunLC+D/wCNLoY6T9aLbambMbqA+0VntvOmQ0f9d9//AFxcpTQ67RhAIDnOLyGtAaN303H6To+iva/8a3Shn/VV+Zs3X9Pe2wEcgEiq7+w5rt68QkgQCYOpHbROPfugLItbqW12B7XF5A9IgwAZ9xd+97UJJAGjYS3MnMxrsLFx6sZtNtG/1bgSTaXHcHPn6Hpt9iqSUySJkT1UvJSTJIcUu5U//9bypJJJJSkkkklKXtPU8O2z/Fu1jm++vpeJZA1Msc20/wDRC8h6VhuzupY2G3m+xrNfAnVfR2NjV2Y1FURW3HphukENB9jg78zajXpPjomMuGQPY28n0u+hvR6LqHm7G2jIxLG67HN2tysX+xL/AGrboNbqra3Frhb7iBrq7+SvP25lH1d6v1Pp7LX/ALHosqu43Gi+1u51TW/4SnY707Ft4vW8a0MyKbWurH0bGe2B/wAJV9JrFSnjMC3ozjMXe70XoMxR+rnbU8FltfaP3mj81bHR8n7T0+p/DmA1PH8qsmp3/ULJxMqrJZJI9w+IKE6zO6ZkB+M7fiWv3vZ2BPtc538h38lPwyo0erHmjxR03D0djyx1Z1hztp+YP/flS6h1/pfT3mrIu/TAAmlnufB+iSPzULqvVqMHCbkZIsdXY9uzY0EtcB6zd3ub7fauH+t/XKOtspdh411GTjuI9Wza1rqnD3VOFbnu+ns2KechGJNi/FgxYzOQBB4epD2VXVej9cfd02HublVOZbVY0AObG122C73bXLwLr/SLui9Yy+l3auxrC1rv3mH3VWf26y1y6gZn1iwLW5eO4UWNEV2AHSdNd27csb629TyuqX0ZOc1js4NLLsmuItaI9GWtDW7q27mo4pnJAn93el2fCMctD6T33cBJJJFhUkkkkpSSSSSn/9fypJJJJSkkkklPTf4uMUZX1vwmESGC15/s1vj/AKS90wrNteG1352PqfNnp/3ryH/E5iG76z25BEtx8d33vIb/ANTvXo31l6iOmfVSzqIjfQx9VY8XWh+HV4f4V9b3J36NI6vjnUsh+Vh5F7j/AE7Ntvb3J9wZWP8Az6vTPqr9SukdQ+r1GVa2ynLeXht9T3N0a41VzSS6h/0Pzq15nfUK7Om4UQ+hrHPA1Jc7dkO/zN695+ruMcTomHjObtdVWA4ef0v4qLeR8B/0v/RWYmoCtDY/5v8A6M8dT0n6w9FzjhmpubW8PtpspIbLK9ge59Lz+it/SM/R1767Ff6fmZXUsoYxxn0TJJsMTHIa391bvXem5WV6GVhGcnFLmmouNYtptAryafVb7qn7R6lNn+lrQekYb8Oxm7ppx3bdnq12NsGhjddvcLd38pnqpHDEni/BXvzqkf1gysVuNRjP1FpNjAdPa0bB/wBUueusw62kh7S49hBK6brv1YHWLmXnKfS6tuwM2tcyJkmPZZud/wAYuU6j/i+69EYl9VrfJxrPzD2P/wDPibkxcRvRdiyiI4T3cLrnUqBWaq2y46T/AHLnMzp1jul3X2Q2PewHmQe39ZRs6rVg5VtVrHvvpe6t4dBAc07H7fuQurfWBudhtx2NLNdR2AH/AFSZHHkjLTTv5MssmMwIJB00cRMnSCsNNZJSLSORE6iVFJSklMVvLC8D2tifmkkp/9DypJJJJSkkkklPqX+Jh/TKRmOtyK2Z91jWV0OeA91bWl25lbvp+9/5itf4zs6tvRMHpL3+kL83IdYQJgUmw1tj+W7IpXkgJBBBgjUELZwc3M6ndhY2XY66rDufebLHFxDCGPtaXOn27cZG9FAaun0ml/U/rjRjRq54bHgJH/U1r3lg22OaPokAj/qf4Lxv/FbV9t+t78t41qY9/wAyD/6UXszhqD4Jsdyun0+1kmhOkitUkkmJgSkp+Zevadc6iP8Au1d/58eqC0vrK3Z9YuqN8Mu//wA+PWajLcqTYjq25dLrQDWLGF4PG3cN0o+df6eZk14+0Um6w17QPoknZt/k7FTRsyyiy4ux2ubVtaAHxMta1r/o/vPCCV8m0F7RXuDAxulgbMwN8bR/N793p/yEHc4iJ08E0zzqkkhlD5A3axI17RKSjJ/1CSSn/9HypJJJJSkkkklM6Wb7WtPBOvwWh0eGnLynD21UuAPnaRT/AOen2qPR8cvsuvI9uPU989p2nao4dhr6fkN4FrmzzqGB/t/8EQuyR2pfw1GJ72X0b/Exhk2Zma4T7dm7zc4H/qal6oRIIXE/4rcJuP8AVxtkQ62zdPiGj0/+r9RdskNr76on8xHagoJ0kkVqlF/Yeakou5+SQQdn5t+toj6z9VH/AHat/wCqKyVtfXQR9a+q/wDhmw/eZWKjL5j5lQ2HkpJJWKfszfc8yY0AnlNJpRNdCfJrpKVm0vOwQ3sFFFKkkkklP//S8qSTqVbA/dLg2GkiZ1IH0dP3klMEklKsNL2h30SdfgkkCzT1XT8L7N9Wr73CHXU2O+RBDVg2MDMDFYPp3ue8/Dc2qv8A892LezesU2fV+2iogPrDKtmujHd/wWJeW/asdg0FLGCPNo9//gu9Q4yalI9SS2MsfXCA10EX2n/F91XAyuitxcZ4N+CPSurn3Ah5Pqbf3LN7tq68Lw7/ABW5Jq+upoZLm5dN1RgxwPX3H/tpe4qe7ANVo15aSkPErpJJIIUoxyVJMeCkovzl9eI/53dVjj7Q9Ya3PrwCPrb1UHn13fkCw06fzS8yiOw8lJJJJqVJJJJKUktFvVaP2U/AswaH5G4OpzwC25g4fW7b+jvY5v0fUb+jSSU//9PypHxbW1PeXGN1b2DSdXNLQgJIhSle6fgDIquvcSG0gEAcuM6hv9hUUkyd8Pp3X4uHjHFs7Odi45vpFJIxyaxqZJ3av/zdr1Sdd62VZdEAyQPCVTSTRfBqz6e/Gu/4/ovU/wCLdz2fXDEyRxQLbHgclpY6tzR/24voBfKySlNUO+rV1s2/VSS+VUkFP1UmPBXyskkovQfX5pb9buo6Rusa772MXPpJJ+T55eaI/KPJSnUaxaw2gurDhvA5LZ90KCSYlna2ttr21OL6wTscRBLfzXFv5qgkkkpSSSSSn//Z 1 XML-Atom-0.41/t/samples/me.jpg000644 000771 000024 00000013115 11174274617 016760 0ustar00miyagawastaff000000 000000 JFIFHH4Photoshop 3.08BIMHH8BIM8BIM' 8BIMH/fflff/ff2Z5-8BIMp8BIMAdobed            "?   3!1AQa"q2B#$Rb34rC%Scs5&DTdE£t6UeuF'Vfv7GWgw5!1AQaq"2B#R3$brCScs4%&5DTdEU6teuFVfv'7GWgw ?I%)$IJI$RI$I%)$IJI$RI$I%)$IOI%)$IJI$RI$$g{_m1|˟#3\{i{3a痋5|Gx/-uV{L5(7bLIJ&=RI$I$$8j8dz"$$VI%)$IJI%&5pkD`)(,A4OUhO`6'ViM$:f_6DgTǧKw{.}8euK[4V p/?' rֺͭookmx?ފ.I5TyP/<-FH+|Ǯ˺f.g$Ndž"=5sr%W#:ĤI9u&3B#ZU_-%}FV _5ُ !v}?ݦf'SZyF^Kӿ=bNڄ֟D[ZxGu 2=jjnַңpdF:o%/[c[G+FEe@kw欮v ]_ܚ͘ꈝZ.~˅Ý]m3oix3rt+WYms2I xgڹnl;$d̹_[3wG`0$r߮ǾUq;E1 ho\S2'HѾ}Sc`V#pOo:OeU7Jhu AV־;c~ ,LZ6,{l:9sŗ&N6:D%d==xcN_h)8L5Nɡ] ߲ r9UFVk(k@<`s}ܶyP`O Ӆz~qtʱ'S\L66C]v1/N{9$@Xq޲_͏V|REIP=>{I2I)7i\ׁ^UjFq-OS}K׿hs/=mp k5?Ssaй 'HdÔO*ݸMu߁+KCw{]>W$-ShOc7Ҫ8xYy!aSLrt&/cs辆b>^TZ{]o=?2ηwK}Tbَ#~Kk6l}*ų]ޡP:ʷsKk-Xz[:~N_W sUDXo.IIC$$X dHFz/_⛪t6W  qYYXTl-h{ []\n6=b:2\@4c;׏k6/G?U~ugc'1:\Ch 5z[O{z#}ca iun{k ,unkmO@vEz/զM4u5}&/9 &cױkÚ`ǂԔ% pGA[F227~9aK[m{؀dGrڪZ@^+9at]OZ&evOnի.bʇYIr!%W9/|~G!oɪfѫk<$)$JRI$ߪ=//u'!kWK6}^3}ÍnmUxw+ѯDWِUMhM+0mk@ h?ŏI}^u[˫5WS6v "<2o_yG践ZK+{]gzfE$hzKoY虝=s~7TpWb ݌6=tպ=eYך#M>[#"ߑcYcsO.sYM[en,{O!;\ئ06 UޕޡwUݏyC}/v+3DZ3VWEGw4pGt9jTX2=;zcIcC̀c],sMelh#_o$vIy<!)=.=I%)n}]UfޣhὍR)oU z^>M6ZqOakgzu+꣦[q1o]z\PՍDkʽuX/ӫen]zv%z#-]5HV({\vϩN{gt !;{~)n5RYC}noqsW7aSN@ݔ;#nL dAV.!ա2#] Ogh~=R=-{,/.:O֋m1EgCGw\\4:@ 9/!wqNktU7_H9޼BH N=,[mvH~ $a-̜kqm6ѿոMpszm*S$=T$?I%)$IJ^[od Lʹ zV6yƳ_u_GccWf5DVzaA ڍzOdco'yhısv+j۠꭭Ů?neWzS貫huMoJv;ӱmkC2)} Wk)0-3{QSehձ~`5<*jwBʫ%H(N;d;~%v\!O*4zt=,ugXs?KujȻig~#PV "Wc۳cA-pw{\a]FN;lֺuN{6)!bX1c3=]WanUNeX] \ /Xwjk ZaUg-rg, [E]'Mwnܱ<}9cK.ɮ"ֈe n۹wz]-I$aRI$I$I%)$IOM.1FW&!ן ͵ߝg!=Kq^R΢#} }UZWW'~#K!XyNͶ'Xϫ>JCVr^}OstkU$έy Qsԗ;vC޽1xnUXKVbj6?OIs>l++H׾Բ1}$ Lr[wezXFrqKj.5i i[GMkAoñivݞv6opwpĞ/^`n5ZMOkFTíJՁ.e) 2&IeN/F%Z'=ω1qv,#pRVjr3:uw_d6=l`[U{@sNa,QTy#-4,$4q'H+ 5R-#o,/؟I)I%)$IOFcȭXWC[Z]έ7!&&[cnȥy $A5-Χv6];yZ\FP}&?4cFxlx 5y`c>oV߭x֦=2^> ܮOhN+TI))i:WǪ K+v}b˿>=f-ʓb:@5^w ҏ^>I^>'fTѳ,ˋյZֿ _&^^`l 7w"'OQv+%m}teb/ IX<ɍSI] kfC{RI%?򤓩Vi"gRSR4D~ $ 4]? Vu6;A X60376݋{7Sgh*ٮwb^[v ,`6 CRKc,}pAUx7Jy>ܳ{/&KM1i{U^ZJCĮI (%I1ढ?wU>>>PyN/2 Testing atom:source Example Entry Frank's JiveBlog XML-Atom-0.41/t/samples/vox.xml000644 000771 000024 00000063700 11174274617 017220 0ustar00miyagawastaff000000 000000 miyagawa's blog Vox 2006-07-18T07:02:12Z miyagawa http://bulknews.vox.com/ tag:vox.com,2006:6p00b8ea067a57dece/ Pirates of Caribbean - Dead Man's Chest tag:vox.com,2006-07-18:asset-6a00b8ea067a57dece00c2251d59be549d 2006-07-18T03:00:19Z 2006-07-18T07:02:12Z

Last night I went to the preview show of "Pirates of Caribbean - Dead Man's Chest" in Roppongi Hills. The movie was fun but all I remember is Keira Knightley's jaw!

She was so cute in Love Actually but these days she's been getting probably thin and that makes her jaw's edge sharp and awful. Hmm ...

 

 Ellegarden - Riot on the Grill tag:vox.com,2006-07-16:asset-6a00b8ea067a57dece00c2251d0fdff219 2006-07-16T11:23:11Z 2006-07-17T07:15:11Z

Ellegarden has been on my antenna for a while, whenever I listen to their song on cable TV stations like MTV Japan. They're a Japanese alternative rock band (kind of emo + punk) and does really great tunes. I just downloaded their (probably first) major album "Riot on the Grill" from iTMS Japan and it surely rocks.

If you like New Found Glory, the Ataris or Blink-182, you'll definitely like ELLEGARDEN as well. Check out Last.fm artist page for more.

 Mocha frapp tag:vox.com,2006-07-16:asset-6a00b8ea067a57dece00c2251dfed68e1d 2006-07-16T06:43:41Z 2006-07-16T06:43:41Z

Rock'n Roll

 Vox tag:vox.com,2006-07-16:asset-6a00b8ea067a57dece00c2251d0b7b8fdb 2006-07-16T02:51:51Z 2006-07-16T02:51:51Z
Vox cafe found in Boston.
Way too HOT tag:vox.com,2006-07-15:asset-6a00b8ea067a57dece00c2251d04798fdb 2006-07-15T08:53:25Z 2006-07-16T19:49:16Z

Tokyo is again getting its craziness to become the hottest place in the world. Today it was up to 95 F (or 36 C) in the daytime. Way too hot.

Fireworks in New York tag:vox.com,2006-07-11:asset-6a00b8ea067a57dece00c2251cb644604a 2006-07-11T06:29:23Z 2006-07-11T06:36:09Z
Here's the video I took on the Ferry.
Westside story tag:vox.com,2006-07-11:asset-6a00b8ea067a57dece00c2251cb4cb604a 2006-07-11T04:03:56Z 2006-07-11T04:03:56Z

coming to Japan this fall

 Materazzi is an idiot tag:vox.com,2006-07-10:asset-6a00b8ea067a57dece00c2251cab768fdb 2006-07-10T09:26:10Z 2006-07-11T01:36:25Z
He's an asshole.
Johnny Depp tag:vox.com,2006-07-10:asset-6a00b8ea067a57dece00c2251ca6158fdb 2006-07-10T04:01:25Z 2006-07-10T04:01:25Z

is here but i cant see

 This is good vs. This is awful tag:vox.com,2006-07-09:asset-6a00b8ea067a57dece00c2251d90098e1d 2006-07-09T05:26:05Z 2006-07-09T16:19:30Z

[this is good] is a great feature and it's funny to see the coincidence with the funniest tag in Japanese social bookmarking site.

See posts tagged これはひどい (this-is-awful) on Hatena Bookmark. Consider it as del.icio.us/tag/thisisawful or something like that. This page lists blog posts and/or news items which are awful, bad, stupid and ridiculous. Especially a good page to start surfing on the net when you're bored.

 XML-Atom-0.41/lib/XML/000755 000771 000024 00000000000 11640225176 015145 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/lib/XML/Atom/000755 000771 000024 00000000000 11640225176 016045 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/lib/XML/Atom.pm000644 000771 000024 00000004315 11640225155 016403 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom; use strict; use 5.008_001; our $VERSION = '0.41'; BEGIN { @XML::Atom::EXPORT = qw( LIBXML DATETIME); if (eval { require XML::LibXML }) { *{XML::Atom::LIBXML} = sub() {1}; } else { require XML::XPath; *{XML::Atom::LIBXML} = sub() {0}; } if (eval { require DateTime::Format::Atom }) { *{XML::Atom::DATETIME} = sub() {1}; } else { *{XML::Atom::DATETIME} = sub() {0}; } local $^W = 0; *XML::XPath::Function::namespace_uri = sub { my $self = shift; my($node, @params) = @_; my $ns = $node->getNamespace($node->getPrefix); if (!$ns) { $ns = ($node->getNamespaces)[0]; } XML::XPath::Literal->new($ns ? $ns->getExpanded : ''); }; $XML::Atom::ForceUnicode = 0; $XML::Atom::DefaultVersion = 0.3; } sub libxml_parser { ## uses old XML::LibXML < 1.70 interface for compat reasons return XML::LibXML->new( #no_network => 1, # v1.63+ expand_xinclude => 0, expand_entities => 1, load_ext_dtd => 0, ext_ent_handler => sub { warn "External entities disabled."; '' }, ); } sub expat_parser { return XML::Parser->new( Handlers => { ExternEnt => sub { warn "External Entities disabled."; '' }, ExternEntFin => sub {}, }, ); } use base qw( XML::Atom::ErrorHandler Exporter ); package XML::Atom::Namespace; use strict; sub new { my $class = shift; my($prefix, $uri) = @_; bless { prefix => $prefix, uri => $uri }, $class; } sub DESTROY { } use vars qw( $AUTOLOAD ); sub AUTOLOAD { (my $var = $AUTOLOAD) =~ s!.+::!!; no strict 'refs'; ($_[0], $var); } 1; __END__ =head1 NAME XML::Atom - Atom feed and API implementation =head1 SYNOPSIS use XML::Atom; =head1 DESCRIPTION Atom is a syndication, API, and archiving format for weblogs and other data. I implements the feed format as well as a client for the API. =head1 LICENSE I is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Benjamin Trott, Tatsuhiko Miyagawa =head1 COPYRIGHT All rights reserved. =cut XML-Atom-0.41/lib/XML/Atom/Base.pm000644 000771 000024 00000024015 11635444454 017265 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Base; use strict; use base qw( XML::Atom::ErrorHandler Class::Data::Inheritable ); use Encode; use XML::Atom; use XML::Atom::Util qw( set_ns first nodelist childlist create_element ); __PACKAGE__->mk_classdata('__attributes', []); sub new { my $class = shift; my $obj = bless {}, $class; $obj->init(@_) or return $class->error($obj->errstr); $obj; } sub init { my $obj = shift; my %param = @_; if (!exists $param{Namespace} and my $ns = $obj->element_ns) { $param{Namespace} = $ns; } $obj->set_ns(\%param); my $elem; unless ($elem = $param{Elem}) { if (LIBXML) { my $doc = XML::LibXML::Document->createDocument('1.0', 'UTF-8'); my $ns = $obj->ns; my ($ns_uri, $ns_prefix); if ( ref $ns and $ns->isa('XML::Atom::Namespace') ) { $ns_uri = $ns->{uri}; $ns_prefix = $ns->{prefix}; } else { $ns_uri = $ns; } if ( $ns_uri and $ns_prefix ) { $elem = $doc->createElement($obj->element_name); $elem->setNamespace( $ns_uri, $ns_prefix, 1 ); } else { $elem = $doc->createElementNS($obj->ns, $obj->element_name); } $doc->setDocumentElement($elem); } else { $elem = XML::XPath::Node::Element->new($obj->element_name); my $ns = XML::XPath::Node::Namespace->new('#default' => $obj->ns); $elem->appendNamespace($ns); } } $obj->{elem} = $elem; $obj; } sub element_name { } sub element_ns { } sub ns { $_[0]->{ns} } sub elem { $_[0]->{elem} } sub version { my $atom = shift; XML::Atom::Util::ns_to_version($atom->ns); } sub content_type { my $atom = shift; if ($atom->version >= 1.0) { return "application/atom+xml"; } else { return "application/x.atom+xml"; } } sub get { my $obj = shift; my($ns, $name) = @_; my @list = $obj->getlist($ns, $name); return $list[0]; } sub getlist { my $obj = shift; my($ns, $name) = @_; my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns; my @node = childlist($obj->elem, $ns_uri, $name); return map { my $val = LIBXML ? $_->textContent : $_->string_value; if ($] >= 5.008) { require Encode; Encode::_utf8_off($val) unless $XML::Atom::ForceUnicode; } $val; } @node; } sub add { my $obj = shift; my($ns, $name, $val, $attr) = @_; return $obj->set($ns, $name, $val, $attr, 1); } sub set { my $obj = shift; my($ns, $name, $val, $attr, $add) = @_; my $ns_uri = ref $ns eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns; my @elem = childlist($obj->elem, $ns_uri, $name); if (!$add && @elem) { $obj->elem->removeChild($_) for @elem; } my $elem = create_element($ns, $name); if (UNIVERSAL::isa($val, 'XML::Atom::Base')) { if (LIBXML) { for my $child ($val->elem->childNodes) { $elem->appendChild($child->cloneNode(1)); } for my $attr ($val->elem->attributes) { next unless ref($attr) eq 'XML::LibXML::Attr'; $elem->setAttribute($attr->getName, $attr->getValue); } } else { for my $child ($val->elem->getChildNodes) { $elem->appendChild($child); } for my $attr ($val->elem->getAttributes) { $elem->appendAttribute($attr); } } } elsif (DATETIME && UNIVERSAL::isa($val, "DateTime")) { return $obj->set($ns, $name, DateTime::Format::Atom->format_datetime($val), $attr, $add); } else { if (LIBXML) { $elem->appendChild(XML::LibXML::Text->new($val)); } else { $elem->appendChild(XML::XPath::Node::Text->new($val)); } } $obj->elem->appendChild($elem); if ($attr) { while (my($k, $v) = each %$attr) { $elem->setAttribute($k, $v); } } return $val; } sub get_attr { my $obj = shift; my($attr) = @_; my $val = $obj->elem->getAttribute($attr); if ($] >= 5.008) { require Encode; Encode::_utf8_off($val) unless $XML::Atom::ForceUnicode; } $val; } sub set_attr { my $obj = shift; if (@_ == 2) { my($attr, $val) = @_; $obj->elem->setAttribute($attr => $val); } elsif (@_ == 3) { my($ns, $attr, $val) = @_; my $attribute = "$ns->{prefix}:$attr"; if (LIBXML) { $obj->elem->setAttributeNS($ns->{uri}, $attribute, $val); } else { my $ns = XML::XPath::Node::Namespace->new( $ns->{prefix} => $ns->{uri} ); $obj->elem->appendNamespace($ns); $obj->elem->setAttribute($attribute => $val); } } } sub get_object { my $obj = shift; my($ns, $name, $class) = @_; my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns; my @elem = childlist($obj->elem, $ns_uri, $name) or return; my @obj = map { $class->new( Elem => $_, Namespace => $ns ) } @elem; return wantarray ? @obj : $obj[0]; } sub mk_elem_accessors { my $class = shift; my (@list) = @_; my $override_ns; if ( ref $list[-1] ) { my $ns_list = pop @list; if ( ref $ns_list eq 'ARRAY' ) { $ns_list = $ns_list->[0]; } if ( ref($ns_list) =~ /Namespace/ ) { $override_ns = $ns_list; } else { if ( ref $ns_list eq 'HASH' ) { $override_ns = XML::Atom::Namespace->new(%$ns_list); } elsif ( not ref $ns_list and $ns_list ) { $override_ns = $ns_list; } } } no strict 'refs'; for my $elem ( @list ) { (my $meth = $elem) =~ tr/\-/_/; *{"${class}::$meth"} = sub { my $obj = shift; if (@_) { return $obj->set( $override_ns || $obj->ns, $elem, $_[0]); } else { return $obj->get( $override_ns || $obj->ns, $elem); } }; } } sub mk_attr_accessors { my $class = shift; my(@list) = @_; no strict 'refs'; for my $attr (@list) { (my $meth = $attr) =~ tr/\-/_/; *{"${class}::$meth"} = sub { my $obj = shift; if (@_) { return $obj->set_attr($attr => $_[0]); } else { return $obj->get_attr($attr); } }; $class->_add_attribute($attr); } } sub _add_attribute { my($class, $attr) = @_; push @{$class->__attributes}, $attr; } sub attributes { my $class = shift; @{ $class->__attributes }; } sub mk_xml_attr_accessors { my($class, @list) = @_; no strict 'refs'; for my $attr (@list) { (my $meth = $attr) =~ tr/\-/_/; *{"${class}::$meth"} = sub { my $obj = shift; if (LIBXML) { my $elem = $obj->elem; if (@_) { $elem->setAttributeNS('http://www.w3.org/XML/1998/namespace', $attr, $_[0]); } return $elem->getAttribute("xml:$attr"); } else { if (@_) { $obj->elem->setAttribute("xml:$attr", $_[0]); } return $obj->elem->getAttribute("xml:$attr"); } }; } } sub mk_object_accessor { my $class = shift; my($name, $ext_class) = @_; no strict 'refs'; (my $meth = $name) =~ tr/\-/_/; *{"${class}::$meth"} = sub { my $obj = shift; my $ns_uri = $ext_class->element_ns || $obj->ns; if (@_) { return $obj->set($ns_uri, $name, $_[0]); } else { return $obj->get_object($ns_uri, $name, $ext_class); } }; } sub mk_object_list_accessor { my $class = shift; my($name, $ext_class, $moniker) = @_; no strict 'refs'; *{"$class\::$name"} = sub { my $obj = shift; my $ns_uri = $ext_class->element_ns || $obj->ns; if (@_) { # setter: clear existent elements first my @elem = childlist($obj->elem, $ns_uri, $name); for my $el (@elem) { $obj->elem->removeChild($el); } # add the new elements for each my $adder = "add_$name"; for my $add_elem (@_) { $obj->$adder($add_elem); } } else { # getter: just call get_object which is a context aware return $obj->get_object($ns_uri, $name, $ext_class); } }; # moniker returns always list: array ref in a scalar context if ($moniker) { *{"$class\::$moniker"} = sub { my $obj = shift; if (@_) { return $obj->$name(@_); } else { my @obj = $obj->$name; return wantarray ? @obj : \@obj; } }; } # add_$name *{"$class\::add_$name"} = sub { my $obj = shift; my($stuff) = @_; my $ns_uri = $ext_class->element_ns || $obj->ns; my $elem = (ref $stuff && UNIVERSAL::isa($stuff, $ext_class)) ? $stuff->elem : create_element($ns_uri, $name); $obj->elem->appendChild($elem); if (ref($stuff) eq 'HASH') { for my $k ( $ext_class->attributes ) { defined $stuff->{$k} or next; $elem->setAttribute($k, $stuff->{$k}); } } }; } sub as_xml { my $obj = shift; if (LIBXML) { my $doc = XML::LibXML::Document->new('1.0', 'UTF-8'); $doc->setDocumentElement($obj->elem->cloneNode(1)); return $doc->toString(1); } else { return '' . "\n" . $obj->elem->toString; } } sub as_xml_utf8 { my $obj = shift; my $xml = $obj->as_xml; if (utf8::is_utf8($xml)) { return Encode::encode_utf8($xml); } return $xml; } 1; XML-Atom-0.41/lib/XML/Atom/Category.pm000644 000771 000024 00000000444 11174274617 020170 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Category; use strict; use base qw( XML::Atom::Base ); use XML::Atom; __PACKAGE__->mk_attr_accessors(qw( term scheme label )); sub element_name { 'category' } ## Maintain backwards compatibility with the old Link->set method. sub set { shift->set_attr(@_) } 1; XML-Atom-0.41/lib/XML/Atom/Client.pm000644 000771 000024 00000022555 11573754402 017636 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Client; use strict; use XML::Atom; use base qw( XML::Atom::ErrorHandler ); use LWP::UserAgent; use XML::Atom::Entry; use XML::Atom::Feed; use XML::Atom::Util qw( first textValue ); use Digest::SHA1 qw( sha1 ); use MIME::Base64 qw( encode_base64 ); use DateTime; use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/'; sub new { my $class = shift; my $client = bless { }, $class; $client->init(@_) or return $class->error($client->errstr); $client; } sub init { my $client = shift; my %param = @_; $client->{ua} = LWP::UserAgent::AtomClient->new($client); $client->{ua}->agent('XML::Atom/' . XML::Atom->VERSION); $client->{ua}->parse_head(0); $client; } sub username { my $client = shift; $client->{username} = shift if @_; $client->{username}; } sub password { my $client = shift; $client->{password} = shift if @_; $client->{password}; } sub use_soap { my $client = shift; $client->{use_soap} = shift if @_; $client->{use_soap}; } sub auth_digest { my $client = shift; $client->{auth_digest} = shift if @_; $client->{auth_digest}; } sub getEntry { my $client = shift; my($url) = @_; my $req = HTTP::Request->new(GET => $url); my $res = $client->make_request($req); return $client->error("Error on GET $url: " . $res->status_line) unless $res->code == 200; XML::Atom::Entry->new(Stream => \$res->content); } sub createEntry { my $client = shift; my($uri, $entry) = @_; return $client->error("Must pass a PostURI before posting") unless $uri; my $req = HTTP::Request->new(POST => $uri); $req->content_type($entry->content_type); my $xml = $entry->as_xml; _utf8_off($xml); $req->content_length(length $xml); $req->content($xml); my $res = $client->make_request($req); return $client->error("Error on POST $uri: " . $res->status_line) unless $res->code == 201; $res->header('Location') || 1; } sub updateEntry { my $client = shift; my($url, $entry) = @_; my $req = HTTP::Request->new(PUT => $url); $req->content_type($entry->content_type); my $xml = $entry->as_xml; _utf8_off($xml); $req->content_length(length $xml); $req->content($xml); my $res = $client->make_request($req); return $client->error("Error on PUT $url: " . $res->status_line) unless $res->code == 200; 1; } sub deleteEntry { my $client = shift; my($url) = @_; my $req = HTTP::Request->new(DELETE => $url); my $res = $client->make_request($req); return $client->error("Error on DELETE $url: " . $res->status_line) unless $res->code == 200; 1; } sub getFeed { my $client = shift; my($uri) = @_; return $client->error("Must pass a FeedURI before retrieving feed") unless $uri; my $req = HTTP::Request->new(GET => $uri); my $res = $client->make_request($req); return $client->error("Error on GET $uri: " . $res->status_line) unless $res->code == 200; my $feed = XML::Atom::Feed->new(Stream => \$res->content) or return $client->error(XML::Atom::Feed->errstr); $feed; } sub make_request { my $client = shift; my($req) = @_; $client->munge_request($req); my $res = $client->{ua}->request($req); $client->munge_response($res); $client->{response} = $res; $res; } sub munge_request { my $client = shift; my($req) = @_; $req->header( Accept => 'application/atom+xml, application/x.atom+xml, application/xml, text/xml, */*', ); my $nonce = $client->make_nonce; my $nonce_enc = encode_base64($nonce, ''); my $now = DateTime->now->iso8601 . 'Z'; my $digest = encode_base64(sha1($nonce . $now . ($client->password || '')), ''); if ($client->use_soap) { my $xml = $req->content || ''; $xml =~ s!^(<\?xml.*?\?>)!!; my $method = $req->method; $xml = ($1 || '') . < @{[ $client->username || '' ]} $digest $nonce_enc $now <$method xmlns="http://schemas.xmlsoap.org/wsdl/http/"> $xml SOAP $req->content($xml); $req->content_length(length $xml); $req->header('SOAPAction', 'http://schemas.xmlsoap.org/wsdl/http/' . $method); $req->method('POST'); $req->content_type('text/xml'); } else { if ($client->username) { $req->header('X-WSSE', sprintf qq(UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"), $client->username || '', $digest, $nonce_enc, $now); $req->header('Authorization', 'WSSE profile="UsernameToken"'); } } } sub munge_response { my $client = shift; my($res) = @_; if ($client->use_soap && (my $xml = $res->content)) { my $doc; if (LIBXML) { my $parser = $client->libxml_parser; $doc = $parser->parse_string($xml); } else { my $xp = XML::XPath->new(xml => $xml); $doc = ($xp->find('/')->get_nodelist)[0]; } my $body = first($doc, NS_SOAP, 'Body'); if (my $fault = first($body, NS_SOAP, 'Fault')) { $res->code(textValue($fault, undef, 'faultcode')); $res->message(textValue($fault, undef, 'faultstring')); $res->content(''); $res->content_length(0); } else { $xml = join '', map $_->toString(LIBXML ? 1 : 0), LIBXML ? $body->childNodes : $body->getChildNodes; $res->content($xml); $res->content_length(1); } } } sub make_nonce { sha1(sha1(time() . {} . rand() . $$)) } sub _utf8_off { if ($] >= 5.008) { require Encode; Encode::_utf8_off($_[0]); } } sub libxml_parser { XML::Atom->libxml_parser } package LWP::UserAgent::AtomClient; use strict; use Scalar::Util; use base qw( LWP::UserAgent ); my %ClientOf; sub new { my($class, $client) = @_; my $ua = $class->SUPER::new; $ClientOf{$ua} = $client; Scalar::Util::weaken($ClientOf{$ua}); $ua; } sub get_basic_credentials { my($ua, $realm, $url, $proxy) = @_; my $client = $ClientOf{$ua} or die "Cannot find $ua"; return $client->username, $client->password; } sub DESTROY { my $self = shift; delete $ClientOf{$self}; } 1; __END__ =head1 NAME XML::Atom::Client - A client for the Atom API =head1 SYNOPSIS use XML::Atom::Client; use XML::Atom::Entry; my $api = XML::Atom::Client->new; $api->username('Melody'); $api->password('Nelson'); my $entry = XML::Atom::Entry->new; $entry->title('New Post'); $entry->content('Content of my post.'); my $EditURI = $api->createEntry($PostURI, $entry); my $feed = $api->getFeed($FeedURI); my @entries = $feed->entries; my $entry = $api->getEntry($EditURI); =head1 DESCRIPTION I implements a client for the Atom API described at I, with the authentication scheme described at I. B the API, and particularly the authentication scheme, are still in flux. =head1 USAGE =head2 XML::Atom::Client->new(%param) =head2 $api->use_soap([ 0 | 1 ]) I supports both the REST and SOAP-wrapper versions of the Atom API. By default, the REST version of the API will be used, but you can turn on the SOAP wrapper--for example, if you need to connect to a server that supports only the SOAP wrapper--by calling I with a value of C<1>: $api->use_soap(1); If called without arguments, returns the current value of the flag. =head2 $api->username([ $username ]) If called with an argument, sets the username for login to I<$username>. Returns the current username that will be used when logging in to the Atom server. =head2 $api->password([ $password ]) If called with an argument, sets the password for login to I<$password>. Returns the current password that will be used when logging in to the Atom server. =head2 $api->createEntry($PostURI, $entry) Creates a new entry. I<$entry> must be an I object. =head2 $api->getEntry($EditURI) Retrieves the entry with the given URL I<$EditURI>. Returns an I object. =head2 $api->updateEntry($EditURI, $entry) Updates the entry at URL I<$EditURI> with the entry I<$entry>, which must be an I object. Returns true on success, false otherwise. =head2 $api->deleteEntry($EditURI) Deletes the entry at URL I<$EditURI>. =head2 $api->getFeed($FeedURI) Retrieves the feed at I<$FeedURI>. Returns an I object representing the feed returned from the server. =head2 ERROR HANDLING Methods return C on error, and the error message can be retrieved using the I method. =head1 AUTHOR & COPYRIGHT Please see the I manpage for author, copyright, and license information. =cut XML-Atom-0.41/lib/XML/Atom/Content.pm000644 000771 000024 00000012207 11573771006 020022 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Content; use strict; use base qw( XML::Atom::Base ); __PACKAGE__->mk_attr_accessors(qw( type mode )); __PACKAGE__->mk_xml_attr_accessors(qw( lang base )); use Encode; use XML::Atom; use MIME::Base64 qw( encode_base64 decode_base64 ); sub element_name { 'content' } sub init { my $content = shift; my %param = @_ == 1 ? (Body => $_[0]) : @_; $content->SUPER::init(%param); if ($param{Body}) { $content->body($param{Body}); } if ($param{Type}) { $content->type($param{Type}); } return $content; } sub body { my $content = shift; my $elem = $content->elem; if (@_) { my $data = shift; if (LIBXML) { $elem->removeChildNodes; } else { $elem->removeChild($_) for $elem->getChildNodes; } if (!_is_printable($data)) { Encode::_utf8_off($data); if (LIBXML) { $elem->appendChild(XML::LibXML::Text->new(encode_base64($data, ''))); } else { $elem->appendChild(XML::XPath::Node::Text->new(encode_base64($data, ''))); } if ($content->version == 0.3) { $content->mode('base64'); } } else { my $copy = '
' . $data . '
'; my $node; eval { if (LIBXML) { my $parser = XML::Atom->libxml_parser; my $tree = $parser->parse_string($copy); $node = $tree->getDocumentElement; } else { my $parser = XML::Atom->expat_parser; my $xp = XML::XPath->new(xml => $copy, parser => $parser); $node = (($xp->find('/')->get_nodelist)[0]->getChildNodes)[0] if $xp; } }; if (!$@ && $node) { $elem->appendChild($node); if ($content->version == 0.3) { $content->mode('xml'); } else { $content->type('xhtml'); } } else { if (LIBXML) { $elem->appendChild(XML::LibXML::Text->new($data)); } else { $elem->appendChild(XML::XPath::Node::Text->new($data)); } if ($content->version == 0.3) { $content->mode('escaped'); } else { $content->type($data =~ /^\s*{__body}) { my $mode; if ($content->version == 0.3) { $mode = $content->mode || 'xml'; } else { $mode = $content->type eq 'xhtml' ? 'xml' : $content->type =~ m![/\+]xml$! ? 'xml' : $content->type eq 'html' ? 'escaped' : $content->type eq 'text' ? 'escaped' : $content->type =~ m!^text/! ? 'escaped' : 'base64'; } if ($mode eq 'xml') { my @children = grep ref($_) =~ /Element/, LIBXML ? $elem->childNodes : $elem->getChildNodes; if (@children) { if (@children == 1 && $children[0]->getLocalName eq 'div') { @children = LIBXML ? $children[0]->childNodes : $children[0]->getChildNodes } $content->{__body} = ''; for my $n (@children) { $content->{__body} .= $n->toString(LIBXML ? 1 : 0); } } else { $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value; } if ($] >= 5.008) { Encode::_utf8_off($content->{__body}) unless $XML::Atom::ForceUnicode; } } elsif ($mode eq 'base64') { my $raw = decode_base64(LIBXML ? $elem->textContent : $elem->string_value); if ($content->type && $content->type =~ m!^text/!) { $content->{__body} = eval { Encode::decode("utf-8", $raw) } || $raw; Encode::_utf8_off($content->{__body}) unless $XML::Atom::ForceUnicode; } else { $content->{__body} = $raw; } } elsif ($mode eq 'escaped') { $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value; } else { $content->{__body} = undef; } } } $content->{__body}; } sub _is_printable { my $data = shift; local $@; # try decoding this $data with UTF-8 my $decoded = ( Encode::is_utf8($data) ? $data : eval { Encode::decode("utf-8", $data, Encode::FB_CROAK) } ); return ! $@ && $decoded =~ /^[\p{IsPrint}\s]*$/; } 1; XML-Atom-0.41/lib/XML/Atom/Entry.pm000644 000771 000024 00000007627 11174274617 017526 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Entry; use strict; use XML::Atom; use base qw( XML::Atom::Thing ); use MIME::Base64 qw( encode_base64 decode_base64 ); use XML::Atom::Person; use XML::Atom::Content; use XML::Atom::Util qw( first ); sub element_name { 'entry' } sub content { my $entry = shift; if (my @arg = @_) { if (ref($arg[0]) ne 'XML::Atom::Content') { $arg[0] = XML::Atom::Content->new(Body => $arg[0], Version => $entry->version); } $entry->set($entry->ns, 'content', @arg); } else { return $entry->get_object($entry->ns, 'content', 'XML::Atom::Content'); } } __PACKAGE__->mk_elem_accessors(qw( summary )); __PACKAGE__->mk_xml_attr_accessors(qw( lang base )); __PACKAGE__->_rename_elements('issued' => 'published'); __PACKAGE__->_rename_elements('modified' => 'updated'); # OMG 0.3 elements ... to be backward compatible __PACKAGE__->mk_elem_accessors(qw( created )); __PACKAGE__->mk_object_accessor( source => 'XML::Atom::Feed' ); 1; __END__ =head1 NAME XML::Atom::Entry - Atom entry =head1 SYNOPSIS use XML::Atom::Entry; my $entry = XML::Atom::Entry->new; $entry->title('My Post'); $entry->content('The content of my post.'); my $xml = $entry->as_xml; my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/'); $entry->set($dc, 'subject', 'Food & Drink'); =head1 USAGE =head2 XML::Atom::Entry->new([ $stream ]) Creates a new entry object, and if I<$stream> is supplied, fills it with the data specified by I<$stream>. Automatically handles autodiscovery if I<$stream> is a URI (see below). Returns the new I object. On failure, returns C. I<$stream> can be any one of the following: =over 4 =item * Reference to a scalar This is treated as the XML body of the entry. =item * Scalar This is treated as the name of a file containing the entry XML. =item * Filehandle This is treated as an open filehandle from which the entry XML can be read. =back =head2 $entry->content([ $content ]) Returns the content of the entry. If I<$content> is given, sets the content of the entry. Automatically handles all necessary escaping. =head2 $entry->author([ $author ]) Returns an I object representing the author of the entry, or C if there is no author information present. If I<$author> is supplied, it should be an I object representing the author. For example: my $author = XML::Atom::Person->new; $author->name('Foo Bar'); $author->email('foo@bar.com'); $entry->author($author); =head2 $entry->link If called in scalar context, returns an I object corresponding to the first IlinkE> tag found in the entry. If called in list context, returns a list of I objects corresponding to all of the IlinkE> tags found in the entry. =head2 $entry->add_link($link) Adds the link I<$link>, which must be an I object, to the entry as a new IlinkE> tag. For example: my $link = XML::Atom::Link->new; $link->type('text/html'); $link->rel('alternate'); $link->href('http://www.example.com/2003/12/post.html'); $entry->add_link($link); =head2 $entry->get($ns, $element) Given an I element I<$ns> and an element name I<$element>, retrieves the value for the element in that namespace. This is useful for retrieving the value of elements not in the main Atom namespace, like categories. For example: my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/'); my $subj = $entry->get($dc, 'subject'); =head2 $entry->getlist($ns, $element) Just like I<$entry-Eget>, but if there are multiple instances of the element I<$element> in the namespace I<$ns>, returns all of them. I will return only the first. =head1 AUTHOR & COPYRIGHT Please see the I manpage for author, copyright, and license information. =cut XML-Atom-0.41/lib/XML/Atom/ErrorHandler.pm000644 000771 000024 00000000635 11174274617 021004 0ustar00miyagawastaff000000 000000 # $Id: ErrorHandler.pm,v 1.1 2003/09/08 00:00:50 btrott Exp $ package XML::Atom::ErrorHandler; use strict; use vars qw( $ERROR ); sub new { bless {}, shift } sub error { my $msg = $_[1] || ''; $msg .= "\n" unless $msg =~ /\n$/; if (ref($_[0])) { $_[0]->{_errstr} = $msg; } else { $ERROR = $msg; } return; } sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR } 1; XML-Atom-0.41/lib/XML/Atom/Feed.pm000644 000771 000024 00000023572 11174274617 017265 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Feed; use strict; use base qw( XML::Atom::Thing ); use XML::Atom; use XML::Atom::Entry; BEGIN { if (LIBXML) { *entries = \&entries_libxml; *add_entry = \&add_entry_libxml; } else { *entries = \&entries_xpath; *add_entry = \&add_entry_xpath; } } sub init { my $atom = shift; my %param = @_ == 1 ? (Stream => $_[0]) : @_; if (UNIVERSAL::isa($param{Stream}, 'URI')) { my @feeds = __PACKAGE__->find_feeds($param{Stream}); return $atom->error("Can't find Atom file") unless @feeds; my $ua = LWP::UserAgent->new; my $req = HTTP::Request->new(GET => $feeds[0]); my $res = $ua->request($req); if ($res->is_success) { $param{Stream} = \$res->content; } } $atom->SUPER::init(%param); } sub find_feeds { my $class = shift; my($uri) = @_; my $ua = LWP::UserAgent->new; my $req = HTTP::Request->new(GET => $uri); my $res = $ua->request($req); return unless $res->is_success; my @feeds; if ($res->content_type eq 'text/html' || $res->content_type eq 'application/xhtml+xml') { my $base_uri = $uri; my $find_links = sub { my($tag, $attr) = @_; if ($tag eq 'link') { return unless $attr->{rel}; my %rel = map { $_ => 1 } split /\s+/, lc($attr->{rel}); (my $type = lc $attr->{type}) =~ s/^\s*//; $type =~ s/\s*$//; push @feeds, URI->new_abs($attr->{href}, $base_uri)->as_string if $rel{alternate} && $type eq 'application/atom+xml'; } elsif ($tag eq 'base') { $base_uri = $attr->{href}; } }; require HTML::Parser; my $p = HTML::Parser->new(api_version => 3, start_h => [ $find_links, "tagname, attr" ]); $p->parse($res->content); } else { @feeds = ($uri); } @feeds; } sub element_name { 'feed' } *language = \⟨ # legacy sub version { my $feed = shift; my $elem = $feed->elem; if (@_) { $elem->setAttribute('version', $_[0]); } $elem->getAttribute('version') || $feed->SUPER::version(@_); } sub entries_libxml { my $feed = shift; my @res = $feed->elem->getElementsByTagNameNS($feed->ns, 'entry') or return; my @entries; for my $res (@res) { my $entry = XML::Atom::Entry->new(Elem => $res->cloneNode(1)); push @entries, $entry; } @entries; } sub entries_xpath { my $feed = shift; my $set = $feed->elem->find("descendant-or-self::*[local-name()='entry' and namespace-uri()='" . $feed->ns . "']"); my @entries; for my $elem ($set->get_nodelist) { ## Delete the link to the parent (feed) element, and append ## the default Atom namespace. $elem->del_parent_link; my $ns = XML::XPath::Node::Namespace->new('#default' => $feed->ns); $elem->appendNamespace($ns); my $entry = XML::Atom::Entry->new(Elem => $elem); push @entries, $entry; } @entries; } sub add_entry_libxml { my $feed = shift; my($entry, $opt) = @_; $opt ||= {}; # When doing an insert, we try to insert before the first so # that we don't screw up any preamble. If there are no existing # 's, then fall back to appending, which should be # semantically identical. my ($first_entry) = $feed->elem->getChildrenByTagNameNS($entry->ns, 'entry'); if ($opt->{mode} && $opt->{mode} eq 'insert' && $first_entry) { $feed->elem->insertBefore($entry->elem, $first_entry); } else { $feed->elem->appendChild($entry->elem); } } sub add_entry_xpath { my $feed = shift; my($entry, $opt) = @_; $opt ||= {}; my $set = $feed->elem->find("*[local-name()='entry' and namespace-uri()='" . $entry->ns . "']"); my $first_entry = $set ? ($set->get_nodelist)[0] : undef; if ($opt->{mode} && $opt->{mode} eq 'insert' && $first_entry) { $feed->elem->insertBefore($entry->elem, $first_entry); } else { $feed->elem->appendChild($entry->elem); } } __PACKAGE__->mk_elem_accessors(qw( generator )); __PACKAGE__->mk_xml_attr_accessors(qw( lang base )); __PACKAGE__->_rename_elements('modified' => 'updated'); __PACKAGE__->_rename_elements('tagline' => 'subtitle'); 1; __END__ =head1 NAME XML::Atom::Feed - Atom feed =head1 SYNOPSIS use XML::Atom::Feed; use XML::Atom::Entry; my $feed = XML::Atom::Feed->new; $feed->title('My Weblog'); $feed->id('tag:example.com,2006:feed-id'); my $entry = XML::Atom::Entry->new; $entry->title('First Post'); $entry->id('tag:example.com,2006:entry-id'); $entry->content('Post Body'); $feed->add_entry($entry); $feed->add_entry($entry, { mode => 'insert' }); my @entries = $feed->entries; my $xml = $feed->as_xml; ## Get a list of the tags in the feed. my $links = $feed->link; ## Find all of the Atom feeds on a given page, using auto-discovery. my @uris = XML::Atom::Feed->find_feeds('http://www.example.com/'); ## Use auto-discovery to load the first Atom feed on a given page. my $feed = XML::Atom::Feed->new(URI->new('http://www.example.com/')); =head1 USAGE =head2 XML::Atom::Feed->new([ $stream ]) Creates a new feed object, and if I<$stream> is supplied, fills it with the data specified by I<$stream>. Automatically handles autodiscovery if I<$stream> is a URI (see below). Returns the new I object. On failure, returns C. I<$stream> can be any one of the following: =over 4 =item * Reference to a scalar This is treated as the XML body of the feed. =item * Scalar This is treated as the name of a file containing the feed XML. =item * Filehandle This is treated as an open filehandle from which the feed XML can be read. =item * URI object This is treated as a URI, and the feed XML will be retrieved from the URI. If the content type returned from fetching the content at URI is I, this method will automatically try to perform auto-discovery by looking for a IlinkE> tag describing the feed URL. If such a URL is found, the feed XML will be automatically retrieved. If the URI is already of a feed, no auto-discovery is necessary, and the feed XML will be retrieved and parsed as normal. =back =head2 XML::Atom::Feed->find_feeds($uri) Given a URI I<$uri>, use auto-discovery to find all of the Atom feeds linked from that page (using IlinkE> tags). Returns a list of feed URIs. =head2 $feed->link If called in scalar context, returns an I object corresponding to the first IlinkE> tag found in the feed. If called in list context, returns a list of I objects corresponding to all of the IlinkE> tags found in the feed. =head2 $feed->add_link($link) Adds the link I<$link>, which must be an I object, to the feed as a new IlinkE> tag. For example: my $link = XML::Atom::Link->new; $link->type('text/html'); $link->rel('alternate'); $link->href('http://www.example.com/'); $feed->add_link($link); =head2 $feed->add_entry($entry) Adds the entry I<$entry>, which must be an I object, to the feed. If you want to add an entry before existent entries, you can pass optional hash reference containing C value set to C. $feed->add_entry($entry, { mode => 'insert' }); =head2 $feed->entries Returns list of XML::Atom::Entry objects contained in the feed. =head2 $feed->language Returns the language of the feed, from I. =head2 $feed->author([ $author ]) Returns an I object representing the author of the entry, or C if there is no author information present. If I<$author> is supplied, it should be an I object representing the author. For example: my $author = XML::Atom::Person->new; $author->name('Foo Bar'); $author->email('foo@bar.com'); $feed->author($author); =head2 $feed->id([ $id ]) Returns an id for the feed. If I<$id> is supplied, set the id. When generating the new feed, it is your responsibility to generate unique ID for the feed and set to XML::Atom::Feed object. You can use I permalink, I URI scheme or I for handy. =head1 UNICODE FLAGS By default, XML::Atom takes off all the Unicode flag fro mthe feed content. For example, my $title = $feed->title; the variable C<$title> contains UTF-8 bytes without Unicode flag set, even if the feed title contains some multibyte chracters. If you don't like this behaviour and wants to andle everything as Unicode characters (rather than UTF-8 bytes), set C<$XML::Atom::ForceUnicode> flag to 1. $XML::Atom::ForceUnicode = 1; then all the data returned from XML::Atom::Feed object and XML::Atom::Entry object etc., will have Unicode flag set. The only exception will be C<< $entry->content->body >>, if content type is not text/* (e.g. image/gif). In that case, the content body is still binary data, without Unicode flag set. =head1 CREATING ATOM 1.0 FEEDS By default, XML::Atom::Feed and other classes (Entry, Link and Content) will create entities using Atom 0.3 namespaces. In order to create 1.0 feed and entry elements, you can set I as a parameter, like: $feed = XML::Atom::Feed->new(Version => 1.0); $entry = XML::Atom::Entry->new(Version => 1.0); Setting those Version to every element would be sometimes painful. In that case, you can override the default version number by setting C<$XML::Atom::DefaultVersion> global variable to "1.0". use XML::Atom; $XML::Atom::DefaultVersion = "1.0"; my $feed = XML::Atom::Feed->new; $feed->title("blah"); my $entry = XML::Atom::Entry->new; $feed->add_entry($entry); $feed->version; # 1.0 =head1 AUTHOR & COPYRIGHT Please see the I manpage for author, copyright, and license information. =cut XML-Atom-0.41/lib/XML/Atom/Link.pm000644 000771 000024 00000000456 11174274617 017313 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Link; use strict; use base qw( XML::Atom::Base ); use XML::Atom; __PACKAGE__->mk_attr_accessors(qw( rel href hreflang title type length )); sub element_name { 'link' } ## Maintain backwards compatibility with the old Link->set method. sub set { shift->set_attr(@_) } 1; XML-Atom-0.41/lib/XML/Atom/Person.pm000644 000771 000024 00000001616 11174274617 017663 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Person; use strict; use base qw( XML::Atom::Base ); use XML::Atom; use XML::Atom::Feed; use XML::Atom::Entry; __PACKAGE__->mk_elem_accessors(qw( email name uri url homepage )); for my $class (qw( XML::Atom::Feed XML::Atom::Entry )) { $class->mk_object_accessor( author => __PACKAGE__ ); $class->mk_object_accessor( contributor => __PACKAGE__ ); } sub element_name { 'author' } 1; __END__ =head1 NAME XML::Atom::Person - Author or contributor object =head1 SYNOPSIS my $person = XML::Atom::Person->new; $person->email('foo@example.com'); $person->name('Foo Bar'); $entry->author($person); =head1 DESCRIPTION I represents an author or contributor element in an Atom feed or entry. =head1 USAGE =head2 XML::Atom::Person->new =head2 $person->email([ $email ]) =head2 $person->name([ $name ]) =head2 $person->uri([ $uri ]) =cut XML-Atom-0.41/lib/XML/Atom/Server.pm000644 000771 000024 00000035060 11635444454 017663 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Server; use strict; use XML::Atom; use base qw( XML::Atom::ErrorHandler ); use MIME::Base64 qw( encode_base64 decode_base64 ); use Digest::SHA1 qw( sha1 ); use XML::Atom::Util qw( first encode_xml textValue ); use XML::Atom::Entry; use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/'; use constant NS_WSSE => 'http://schemas.xmlsoap.org/ws/2002/07/secext'; use constant NS_WSU => 'http://schemas.xmlsoap.org/ws/2002/07/utility'; sub handler ($$) { my $class = shift; my($r) = @_; require Apache::Constants; if (lc($r->dir_config('Filter') || '') eq 'on') { $r = $r->filter_register; } my $server = $class->new or die $class->errstr; $server->{apache} = $r; $server->run; return Apache::Constants::OK(); } sub new { my $class = shift; my $server = bless { }, $class; $server->init(@_) or return $class->error($server->errstr); $server; } sub init { my $server = shift; $server->{param} = {}; unless ($ENV{MOD_PERL}) { require CGI; $server->{cgi} = CGI->new({}); } $server; } sub run { my $server = shift; (my $pi = $server->path_info) =~ s!^/!!; my @args = split /\//, $pi; for my $arg (@args) { my($k, $v) = split /=/, $arg, 2; $server->request_param($k, $v); } if (my $action = $server->request_header('SOAPAction')) { $server->{is_soap} = 1; $action =~ s/"//g; my($method) = $action =~ m!/([^/]+)$!; $server->request_method($method); } my $out; eval { defined($out = $server->handle_request) or die $server->errstr; if (defined $out && $server->{is_soap}) { $out =~ s!^(<\?xml.*?\?>)!!; $out = < $out SOAP } }; if ($@) { $out = $server->show_error($@); } $server->send_http_header; $server->print($out); 1; } sub handle_request; sub password_for_user; sub uri { my $server = shift; $ENV{MOD_PERL} ? $server->{apache}->uri : $server->{cgi}->url; } sub path_info { my $server = shift; return $server->{__path_info} if exists $server->{__path_info}; my $path_info; if ($ENV{MOD_PERL}) { ## mod_perl often leaves part of the script name (Location) ## in the path info, for some reason. This should remove it. $path_info = $server->{apache}->path_info; if ($path_info) { my($script_last) = $server->{apache}->location =~ m!/([^/]+)$!; $path_info =~ s!^/$script_last!!; } } else { $path_info = $server->{cgi}->path_info; } $server->{__path_info} = $path_info; } sub request_header { my $server = shift; my($key) = @_; if ($ENV{MOD_PERL}) { return $server->{apache}->header_in($key); } else { ($key = uc($key)) =~ tr/-/_/; return $ENV{'HTTP_' . $key}; } } sub request_method { my $server = shift; if (@_) { $server->{request_method} = shift; } elsif (!exists $server->{request_method}) { $server->{request_method} = $ENV{MOD_PERL} ? $server->{apache}->method : $ENV{REQUEST_METHOD}; } $server->{request_method}; } sub request_content { my $server = shift; unless (exists $server->{request_content}) { if ($ENV{MOD_PERL}) { ## Read from $server->{apache} my $r = $server->{apache}; my $len = $server->request_header('Content-length'); $r->read($server->{request_content}, $len); } else { ## Read from STDIN my $len = $ENV{CONTENT_LENGTH} || 0; read STDIN, $server->{request_content}, $len; } } $server->{request_content}; } sub request_param { my $server = shift; my $k = shift; $server->{param}{$k} = shift if @_; $server->{param}{$k}; } sub response_header { my $server = shift; my($key, $val) = @_; if ($ENV{MOD_PERL}) { $server->{apache}->header_out($key, $val); } else { unless ($key =~ /^-/) { ($key = lc($key)) =~ tr/-/_/; $key = '-' . $key; } $server->{cgi_headers}{$key} = $val; } } sub response_code { my $server = shift; $server->{response_code} = shift if @_; $server->{response_code}; } sub response_content_type { my $server = shift; $server->{response_content_type} = shift if @_; $server->{response_content_type}; } sub send_http_header { my $server = shift; my $type = $server->response_content_type || 'application/x.atom+xml'; if ($ENV{MOD_PERL}) { $server->{apache}->status($server->response_code || 200); $server->{apache}->send_http_header($type); } else { $server->{cgi_headers}{-status} = $server->response_code || 200; $server->{cgi_headers}{-type} = $type; print $server->{cgi}->header(%{ $server->{cgi_headers} }); } } sub print { my $server = shift; if ($ENV{MOD_PERL}) { $server->{apache}->print(@_); } else { CORE::print(@_); } } sub error { my $server = shift; my($code, $msg) = @_; $server->response_code($code) if ref($server); return $server->SUPER::error($msg); } sub show_error { my $server = shift; my($err) = @_; chomp($err = encode_xml($err)); if ($server->{is_soap}) { my $code = $server->response_code; if ($code >= 400) { $server->response_code(500); } return < $code $err FAULT } else { return < $err ERR } } sub get_auth_info { my $server = shift; my %param; if ($server->{is_soap}) { my $xml = $server->xml_body; my $auth = first($xml, NS_WSSE, 'UsernameToken'); $param{Username} = textValue($auth, NS_WSSE, 'Username'); $param{PasswordDigest} = textValue($auth, NS_WSSE, 'Password'); $param{Nonce} = textValue($auth, NS_WSSE, 'Nonce'); $param{Created} = textValue($auth, NS_WSSE, 'Created'); } else { my $req = $server->request_header('X-WSSE') or return $server->auth_failure(401, 'X-WSSE authentication required'); $req =~ s/^(?:WSSE|UsernameToken) //; for my $i (split /,\s*/, $req) { my($k, $v) = split /=/, $i, 2; $v =~ s/^"//; $v =~ s/"$//; $param{$k} = $v; } } \%param; } sub authenticate { my $server = shift; my $auth = $server->get_auth_info or return; for my $f (qw( Username PasswordDigest Nonce Created )) { return $server->auth_failure(400, "X-WSSE requires $f") unless $auth->{$f}; } my $password = $server->password_for_user($auth->{Username}); defined($password) or return $server->auth_failure(403, 'Invalid login'); my $expected = encode_base64(sha1( decode_base64($auth->{Nonce}) . $auth->{Created} . $password ), ''); return $server->auth_failure(403, 'Invalid login') unless $expected eq $auth->{PasswordDigest}; return 1; } sub auth_failure { my $server = shift; $server->response_header('WWW-Authenticate', 'WSSE profile="UsernameToken"'); return $server->error(@_); } sub xml_body { my $server = shift; unless (exists $server->{xml_body}) { if (LIBXML) { my $parser = $server->libxml_parser; $server->{xml_body} = $parser->parse_string($server->request_content); } else { $server->{xml_body} = XML::XPath->new(xml => $server->request_content); } } $server->{xml_body}; } sub atom_body { my $server = shift; my $atom; if ($server->{is_soap}) { my $xml = $server->xml_body; $atom = XML::Atom::Entry->new(Doc => first($xml, NS_SOAP, 'Body')) or return $server->error(500, XML::Atom::Entry->errstr); } else { $atom = XML::Atom::Entry->new(Stream => \$server->request_content) or return $server->error(500, XML::Atom::Entry->errstr); } $atom; } sub libxml_parser { XML::Atom->libxml_parser } 1; __END__ =head1 NAME XML::Atom::Server - A server for the Atom API =head1 SYNOPSIS package My::Server; use base qw( XML::Atom::Server ); sub handle_request { my $server = shift; $server->authenticate or return; my $method = $server->request_method; if ($method eq 'POST') { return $server->new_post; } ... } my %Passwords; sub password_for_user { my $server = shift; my($username) = @_; $Passwords{$username}; } sub new_post { my $server = shift; my $entry = $server->atom_body or return; ## $entry is an XML::Atom::Entry object. ## ... Save the new entry ... } package main; my $server = My::Server->new; $server->run; =head1 DESCRIPTION I provides a base class for Atom API servers. It handles all core server processing, both the SOAP and REST formats of the protocol, and WSSE authentication. It can also run as either a mod_perl handler or as part of a CGI program. It does not provide functions specific to any particular implementation, such as posting an entry, retrieving a list of entries, deleting an entry, etc. Implementations should subclass I, overriding the I method, and handle all functions such as this themselves. =head1 SUBCLASSING =head2 Request Handling Subclasses of I must override the I method to perform all request processing. The implementation must set all response headers, including the response code and any relevant HTTP headers, and should return a scalar representing the response body to be sent back to the client. For example: sub handle_request { my $server = shift; my $method = $server->request_method; if ($method eq 'POST') { return $server->new_post; } ## ... handle GET, PUT, etc } sub new_post { my $server = shift; my $entry = $server->atom_body or return; my $id = save_this_entry($entry); ## Implementation-specific $server->response_header(Location => $server->uri . '/entry_id=' . $id); $server->response_code(201); $server->response_content_type('application/x.atom+xml'); return serialize_entry($entry); ## Implementation-specific } =head2 Authentication Servers that require authentication for posting or retrieving entries or feeds should override the I method. Given a username (from the WSSE header), I should return that user's password in plaintext. This will then be combined with the nonce and the creation time to generate the digest, which will be compared with the digest sent in the WSSE header. If the supplied username doesn't exist in your user database or alike, just return C. For example: my %Passwords = ( foo => 'bar' ); ## The password for "foo" is "bar". sub password_for_user { my $server = shift; my($username) = @_; $Passwords{$username}; } =head1 METHODS I provides a variety of methods to be used by subclasses for retrieving headers, content, and other request information, and for setting the same on the response. =head2 Client Request Parameters =over 4 =item * $server->uri Returns the URI of the Atom server implementation. =item * $server->request_method Returns the name of the request method sent to the server from the client (for example, C, C, etc). Note that if the client sent the request in a SOAP envelope, the method is obtained from the I HTTP header. =item * $server->request_header($header) Retrieves the value of the HTTP request header I<$header>. =item * $server->request_content Returns a scalar containing the contents of a POST or PUT request from the client. =item * $server->request_param($param) I automatically parses the PATH_INFO sent in the request and breaks it up into key-value pairs. This can be used to pass parameters. For example, in the URI http://localhost/atom-server/entry_id=1 the I parameter would be set to C<1>. I returns the value of the value of the parameter I<$param>. =back =head2 Setting up the Response =over 4 =item * $server->response_header($header, $value) Sets the value of the HTTP response header I<$header> to I<$value>. =item * $server->response_code([ $code ]) Returns the current response code to be sent back to the client, and if I<$code> is given, sets the response code. =item * $server->response_content_type([ $type ]) Returns the current I header to be sent back to the client, and I<$type> is given, sets the value for that header. =back =head2 Processing the Request =over 4 =item * $server->authenticate Attempts to authenticate the request based on the authentication information present in the request (currently just WSSE). This will call the I method in the subclass to obtain the cleartext password for the username given in the request. =item * $server->atom_body Returns an I object containing the entry sent in the request. =back =head1 USAGE Once you have defined your server subclass, you can set it up either as a CGI program or as a mod_perl handler. A simple CGI program would look something like this: #!/usr/bin/perl -w use strict; use My::Server; my $server = My::Server->new; $server->run; A simple mod_perl handler configuration would look something like this: PerlModule My::Server SetHandler perl-script PerlHandler My::Server =head1 ERROR HANDLING If you wish to return an error from I, you can use the built-in I method: sub handle_request { my $server = shift; ... return $server->error(500, "Something went wrong"); } This will be returned to the client with a response code of 500 and an error string of C. Errors are automatically serialized into SOAP faults if the incoming request is enclosed in a SOAP envelope. =head1 AUTHOR & COPYRIGHT Please see the I manpage for author, copyright, and license information. =cut XML-Atom-0.41/lib/XML/Atom/Thing.pm000644 000771 000024 00000007140 11573771006 017461 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Thing; use strict; use base qw( XML::Atom::Base ); use XML::Atom; use base qw( XML::Atom::ErrorHandler ); use XML::Atom::Util qw( first nodelist childlist create_element ); use XML::Atom::Category; use XML::Atom::Link; use LWP::UserAgent; BEGIN { if (LIBXML) { *init = \&init_libxml; } else { *init = \&init_xpath; } } sub init_libxml { my $atom = shift; my %param = @_ == 1 ? (Stream => $_[0]) : @_; if (my $stream = delete $param{Stream}) { my $parser = delete $param{Parser} || XML::Atom->libxml_parser; my $doc; if (ref($stream) eq 'SCALAR') { $doc = $parser->parse_string($$stream); } elsif (ref($stream)) { $doc = $parser->parse_fh($stream); } else { $doc = $parser->parse_file($stream); } $param{Elem} = $doc->getDocumentElement; } elsif (my $doc = delete $param{Doc}) { $param{Elem} = $doc->getDocumentElement; } $atom->SUPER::init(%param); $atom->fixup_ns; return $atom; } sub fixup_ns { my $obj = shift; $obj->{ns} = $obj->elem->namespaceURI; } sub init_xpath { my $atom = shift; my %param = @_ == 1 ? (Stream => $_[0]) : @_; my $elem_name = $atom->element_name; if (my $stream = delete $param{Stream}) { my $parser = delete $param{Parser} || XML::Atom->expat_parser; my $xp; if (ref($stream) eq 'SCALAR') { $xp = XML::XPath->new(xml => $$stream, parser => $parser); } elsif (ref($stream)) { $xp = XML::XPath->new(ioref => $stream, parser => $parser); } else { $xp = XML::XPath->new(filename => $stream, parser => $parser); } my $set = $xp->find('/' . $elem_name); unless ($set && $set->size) { $set = $xp->find('/'); } $param{Elem} = ($set->get_nodelist)[0]; } elsif (my $doc = delete $param{Doc}) { $param{Elem} = $doc; } elsif (my $elem = $param{Elem}) { my $xp = XML::XPath->new(context => $elem); my $set = $xp->find('/' . $elem_name); unless ($set && $set->size) { $set = $xp->find('/'); } $param{Elem} = ($set->get_nodelist)[0]; } $atom->SUPER::init(%param); $atom; } sub set { my $atom = shift; my($ns, $name, $val, $attr, $add) = @_; if (ref($val) =~ /Element$/) { $atom->elem->appendChild($val); return $val; } else { return $atom->SUPER::set(@_); } } # common elements __PACKAGE__->mk_elem_accessors(qw( icon id logo title )); # updated & rights are in renamed # common multiple elements __PACKAGE__->mk_object_list_accessor('link' => 'XML::Atom::Link', 'links'); __PACKAGE__->mk_object_list_accessor('category' => 'XML::Atom::Category', 'categories'); __PACKAGE__->mk_object_list_accessor('author' => 'XML::Atom::Person', 'authors'); __PACKAGE__->mk_object_list_accessor('contributor' => 'XML::Atom::Person', 'contributors'); __PACKAGE__->_rename_elements('copyright' => 'rights'); # 0.3 -> 1.0 elements aliasing sub _rename_elements { my($class, $atom03, $atom10) = @_; no strict 'refs'; *{"$class\::$atom03"} = sub { my $self = shift; if ($self->version eq "1.0") { return $self->$atom10(@_); } @_ > 0 ? $self->set($self->ns, $atom03, @_) : $self->get($self->ns, $atom03); }; *{"$class\::$atom10"} = sub { my $self = shift; if ($self->version eq "0.3") { return $self->$atom03(@_); } @_ > 0 ? $self->set($self->ns, $atom10, @_) : $self->get($self->ns, $atom10); }; } 1; XML-Atom-0.41/lib/XML/Atom/Util.pm000644 000771 000024 00000007676 11174274617 017346 0ustar00miyagawastaff000000 000000 # $Id$ package XML::Atom::Util; use strict; use XML::Atom; use vars qw( @EXPORT_OK @ISA ); use Encode; use Exporter; @EXPORT_OK = qw( set_ns first nodelist childlist textValue iso2dt encode_xml create_element ); @ISA = qw( Exporter ); our %NS_MAP = ( '0.3' => 'http://purl.org/atom/ns#', '1.0' => 'http://www.w3.org/2005/Atom', ); our %NS_VERSION = reverse %NS_MAP; sub set_ns { my $thing = shift; my($param) = @_; if (my $ns = delete $param->{Namespace}) { $thing->{ns} = $ns; $thing->{version} = $NS_VERSION{$ns}; } else { my $version = delete $param->{Version} || $XML::Atom::DefaultVersion; $version = '1.0' if $version == 1; my $ns = $NS_MAP{$version} or $thing->error("Unknown version: $version"); $thing->{ns} = $ns; $thing->{version} = $version; } } sub ns_to_version { my $ns = shift; $NS_VERSION{$ns}; } sub first { my @nodes = nodelist(@_); return unless @nodes; return $nodes[0]; } sub nodelist { if (LIBXML) { return $_[1] ? $_[0]->getElementsByTagNameNS($_[1], $_[2]) : $_[0]->getElementsByTagName($_[2]); } else { my $set = $_[1] ? $_[0]->find("descendant::*[local-name()='$_[2]' and namespace-uri()='$_[1]']") : $_[0]->find("descendant::$_[2]"); return unless $set && $set->isa('XML::XPath::NodeSet'); return $set->get_nodelist; } } sub childlist { if (LIBXML) { return $_[1] ? $_[0]->getChildrenByTagNameNS($_[1], $_[2]) : $_[0]->getChildrenByTagName($_[2]); } else { my $set = $_[1] ? $_[0]->find("*[local-name()='$_[2]' and namespace-uri()='$_[1]']") : $_[0]->find($_[2]); return unless $set && $set->isa('XML::XPath::NodeSet'); return $set->get_nodelist; } } sub textValue { my $node = first(@_) or return; LIBXML ? $node->textContent : $node->string_value; } sub iso2dt { my($iso) = @_; return unless $iso =~ /^(\d{4})(?:-?(\d{2})(?:-?(\d\d?)(?:T(\d{2}):(\d{2}):(\d{2})(?:\.\d+)?(?:Z|([+-]\d{2}:\d{2}))?)?)?)?/; my($y, $mo, $d, $h, $m, $s, $zone) = ($1, $2 || 1, $3 || 1, $4 || 0, $5 || 0, $6 || 0, $7); require DateTime; my $dt = DateTime->new( year => $y, month => $mo, day => $d, hour => $h, minute => $m, second => $s, time_zone => 'UTC', ); if ($zone && $zone ne 'Z') { my $seconds = DateTime::TimeZone::offset_as_seconds($zone); $dt->subtract(seconds => $seconds); } $dt; } my %Map = ('&' => '&', '"' => '"', '<' => '<', '>' => '>', '\'' => '''); my $RE = join '|', keys %Map; sub encode_xml { my($str) = @_; $str =~ s!($RE)!$Map{$1}!g; $str; } sub create_element { my($ns, $name) = @_; my($ns_uri, $ns_prefix); if (ref $ns eq 'XML::Atom::Namespace') { $ns_uri = $ns->{uri}; $ns_prefix = $ns->{prefix}; } else { $ns_uri = $ns; } my $elem; if (LIBXML) { $elem = XML::LibXML::Element->new($name); $elem->setNamespace($ns_uri, $ns_prefix ? $ns_prefix : ()); } else { $ns_prefix ||= '#default'; $elem = XML::XPath::Node::Element->new($name); my $ns = XML::XPath::Node::Namespace->new($ns_prefix => $ns_uri); $elem->appendNamespace($ns); } return $elem; } 1; __END__ =head1 NAME XML::Atom::Util - Utility functions =head1 SYNOPSIS use XML::Atom::Util qw( iso2dt ); my $dt = iso2dt($entry->issued); =head1 USAGE =head2 iso2dt($iso) Transforms the ISO-8601 date I<$iso> into a I object and returns the I object. =head2 encode_xml($str) Encodes characters with special meaning in XML into entities and returns the encoded string. =head1 AUTHOR & COPYRIGHT Please see the I manpage for author, copyright, and license information. =cut XML-Atom-0.41/inc/Module/000755 000771 000024 00000000000 11640225176 015735 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/inc/Module/Install/000755 000771 000024 00000000000 11640225176 017343 5ustar00miyagawastaff000000 000000 XML-Atom-0.41/inc/Module/Install.pm000644 000771 000024 00000030135 11640225175 017702 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. XML-Atom-0.41/inc/Module/Install/Base.pm000644 000771 000024 00000002147 11640225176 020557 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 XML-Atom-0.41/inc/Module/Install/Can.pm000644 000771 000024 00000003333 11640225176 020404 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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 XML-Atom-0.41/inc/Module/Install/Fetch.pm000644 000771 000024 00000004627 11640225176 020743 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; XML-Atom-0.41/inc/Module/Install/Include.pm000644 000771 000024 00000001015 11640225176 021261 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; XML-Atom-0.41/inc/Module/Install/Makefile.pm000644 000771 000024 00000027032 11640225176 021422 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 XML-Atom-0.41/inc/Module/Install/Metadata.pm000644 000771 000024 00000043123 11640225176 021424 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; XML-Atom-0.41/inc/Module/Install/Repository.pm000644 000771 000024 00000004256 11640225176 022067 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 XML-Atom-0.41/inc/Module/Install/Win32.pm000644 000771 000024 00000003403 11640225176 020603 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; XML-Atom-0.41/inc/Module/Install/WriteAll.pm000644 000771 000024 00000002376 11640225176 021434 0ustar00miyagawastaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;