init

livejournal/cgi-bin/XML/Atom/Client.pm

@@ -0,0 +1,348 @@
+# $Id: Client.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+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_ATOM => 'http://purl.org/atom/ns#';
+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;
+}
+
+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('application/x.atom+xml');
+    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('application/x.atom+xml');
+    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);
+    $res;
+}
+
+sub munge_request {
+    my $client = shift;
+    my($req) = @_;
+    $req->header(
+        Accept => '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 || '') . <<SOAP;
+<soap:Envelope
+  xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"
+  xmlns:wsu="http://schemas.xmlsoap.org/ws/2002/07/utility"
+  xmlns:wsse="http://schemas.xmlsoap.org/ws/2002/07/secext">
+  <soap:Header>
+    <wsse:Security>
+      <wsse:UsernameToken>
+        <wsse:Username>@{[ $client->username || '' ]}</wsse:Username>
+        <wsse:Password Type="wsse:PasswordDigest">$digest</wsse:Password>
+        <wsse:Nonce>$nonce_enc</wsse:Nonce>
+        <wsu:Created>$now</wsu:Created>
+      </wsse:UsernameToken>
+    </wsse:Security>
+  </soap:Header>
+  <soap:Body>
+    <$method xmlns="http://schemas.xmlsoap.org/wsdl/http/">
+$xml
+    </$method>
+  </soap:Body>
+</soap:Envelope>
+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 {
+        $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 = XML::LibXML->new;
+            $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 {
+    my $val = shift;
+    if ($] >= 5.008) {
+        require Encode;
+        Encode::_utf8_off($val);
+    }
+}
+
+package LWP::UserAgent::AtomClient;
+use strict;
+
+use base qw( LWP::UserAgent );
+
+my %ClientOf;
+sub new {
+    my($class, $client) = @_;
+    my $ua = $class->SUPER::new;
+    $ClientOf{$ua} = $client;
+    $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<XML::Atom::Client> implements a client for the Atom API described at
+I<http://bitworking.org/projects/atom/draft-gregorio-09.html>, with the
+authentication scheme described at
+I<http://www.intertwingly.net/wiki/pie/DifferentlyAbledClients>.
+
+B<NOTE:> 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<XML::Atom::Client> 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<use_soap> 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<XML::Atom::Entry> object.
+
+=head2 $api->getEntry($EditURI)
+
+Retrieves the entry with the given URL I<$EditURI>.
+
+Returns an I<XML::Atom::Entry> object.
+
+=head2 $api->updateEntry($EditURI, $entry)
+
+Updates the entry at URL I<$EditURI> with the entry I<$entry>, which must be
+an I<XML::Atom::Entry> 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<XML::Atom::Feed> object representing the feed returned
+from the server.
+
+=head2 ERROR HANDLING
+
+Methods return C<undef> on error, and the error message can be retrieved
+using the I<errstr> method.
+
+=head1 AUTHOR & COPYRIGHT
+
+Please see the I<XML::Atom> manpage for author, copyright, and license
+information.
+
+=cut

livejournal/cgi-bin/XML/Atom/Content.pm

@@ -0,0 +1,157 @@
+# $Id: Content.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Content;
+use strict;
+
+use XML::Atom;
+use base qw( XML::Atom::ErrorHandler );
+use XML::Atom::Util qw( remove_default_ns );
+use MIME::Base64 qw( encode_base64 decode_base64 );
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+sub new {
+    my $class = shift;
+    my $content = bless {}, $class;
+    $content->init(@_) or return $class->error($content->errstr);
+    $content;
+}
+
+sub init {
+    my $content = shift;
+    my %param = @_ == 1 ? (Body => $_[0]) : @_;
+    my $elem;
+    unless ($elem = $param{Elem}) {
+        if (LIBXML) {
+            my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
+            $elem = $doc->createElementNS(NS, 'content');
+            $doc->setDocumentElement($elem);
+        } else {
+            $elem = XML::XPath::Node::Element->new('content');
+        }
+    }
+    $content->{elem} = $elem;
+    if ($param{Body}) {
+        $content->body($param{Body});
+    }
+    if ($param{Type}) {
+        $content->type($param{Type});
+    }
+    $content;
+}
+
+sub elem { $_[0]->{elem} }
+
+sub type {
+    my $content = shift;
+    if (@_) {
+        $content->elem->setAttribute('type', shift);
+    }
+    $content->elem->getAttribute('type');
+}
+
+sub mode {
+    my $content = shift;
+    $content->elem->getAttribute('mode');
+}
+
+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)) {
+            if (LIBXML) {
+               $elem->appendChild(XML::LibXML::Text->new(encode_base64($data, '')));
+            } else {
+               $elem->appendChild(XML::XPath::Node::Text->new(encode_base64($data, '')));
+            }
+            $elem->setAttribute('mode', 'base64');
+        } else {
+            my $copy = '<div xmlns="http://www.w3.org/1999/xhtml">' .
+                       $data .
+                       '</div>';
+            my $node;
+            eval {
+                if (LIBXML) {
+                    my $parser = XML::LibXML->new;
+                    my $tree = $parser->parse_string($copy);
+                    $node = $tree->getDocumentElement;
+                } else {
+                    my $xp = XML::XPath->new(xml => $copy);
+                    $node = (($xp->find('/')->get_nodelist)[0]->getChildNodes)[0]
+                        if $xp;
+                }
+            };
+            if (!$@ && $node) {
+                $elem->appendChild($node);
+                $elem->setAttribute('mode', 'xml');
+            } else {
+                if (LIBXML) {
+                    $elem->appendChild(XML::LibXML::Text->new($data));
+                } else {
+                    $elem->appendChild(XML::XPath::Node::Text->new($data));
+                }
+                $elem->setAttribute('mode', 'escaped');
+            }
+        }
+    } else {
+        unless (exists $content->{__body}) {
+            my $mode = $elem->getAttribute('mode') || 'xml';
+            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) {
+                        remove_default_ns($n) if LIBXML;
+                        $content->{__body} .= $n->toString(LIBXML ? 1 : 0);
+                    }
+                } else {
+                    $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
+                }
+            } elsif ($mode eq 'base64') {
+                $content->{__body} = decode_base64(LIBXML ? $elem->textContent : $elem->string_value);
+            } elsif ($mode eq 'escaped') {
+                $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
+            } else {
+                $content->{__body} = undef;
+            }
+            if ($] >= 5.008) {
+                require Encode;
+                Encode::_utf8_off($content->{__body});
+            }
+        }
+    }
+    $content->{__body};
+}
+
+sub _is_printable {
+    my $data = shift;
+
+    # printable ASCII or UTF-8 bytes
+    $data =~ /^(?:[\x09\x0a\x0d\x20-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf])*$/;
+}
+
+sub as_xml {
+    my $content = shift;
+    if (LIBXML) {
+        my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
+        $doc->setDocumentElement($content->elem);
+        return $doc->toString(1);
+    } else {
+        return $content->elem->toString;
+    }
+}
+
+1;

livejournal/cgi-bin/XML/Atom/Entry.pm

@@ -0,0 +1,131 @@
+# $Id: Entry.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+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 );
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+sub element_name { 'entry' }
+
+sub content {
+    my $entry = shift;
+    my @arg = @_;
+    if (@arg && ref($arg[0]) ne 'XML::Atom::Content') {
+        $arg[0] = XML::Atom::Content->new($arg[0]);
+    }
+    $entry->_element('XML::Atom::Content', 'content', @arg);
+}
+
+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<XML::Atom::Entry> object. On failure, returns C<undef>.
+
+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<XML::Atom::Person> object representing the author of the entry,
+or C<undef> if there is no author information present.
+
+If I<$author> is supplied, it should be an I<XML::Atom::Person> 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<XML::Atom::Link> object
+corresponding to the first I<E<lt>linkE<gt>> tag found in the entry.
+
+If called in list context, returns a list of I<XML::Atom::Link> objects
+corresponding to all of the I<E<lt>linkE<gt>> tags found in the entry.
+
+=head2 $entry->add_link($link)
+
+Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
+the entry as a new I<E<lt>linkE<gt>> 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<XML::Atom::Namespace> 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-E<gt>get>, but if there are multiple instances of the
+element I<$element> in the namespace I<$ns>, returns all of them. I<get>
+will return only the first.
+
+=head1 AUTHOR & COPYRIGHT
+
+Please see the I<XML::Atom> manpage for author, copyright, and license
+information.
+
+=cut

livejournal/cgi-bin/XML/Atom/ErrorHandler.pm

@@ -0,0 +1,21 @@
+# $Id: ErrorHandler.pm,v 1.1 2005/04/15 17:37:32 bradfitz 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;

livejournal/cgi-bin/XML/Atom/Feed.pm

@@ -0,0 +1,256 @@
+# $Id: Feed.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Feed;
+use strict;
+
+use XML::Atom;
+use base qw( XML::Atom::Thing );
+use XML::Atom::Entry;
+BEGIN {
+    if (LIBXML) {
+        *entries = \&entries_libxml;
+        *add_entry = \&add_entry_libxml;
+    } else {
+        *entries = \&entries_xpath;
+        *add_entry = \&add_entry_xpath;
+    }
+}
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+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' }
+
+sub language {
+    my $feed = shift;
+    if (LIBXML) {
+        my $elem = $feed->{doc}->getDocumentElement;
+        if (@_) {
+            $elem->setAttributeNS('http://www.w3.org/XML/1998/namespace',
+                'lang', $_[0]);
+        }
+        return $elem->getAttribute('lang');
+    } else {
+        if (@_) {
+            $feed->{doc}->setAttribute('xml:lang', $_[0]);
+        }
+        return $feed->{doc}->getAttribute('xml:lang');
+    }
+}
+
+sub version {
+    my $feed = shift;
+    my $elem = LIBXML ? $feed->{doc}->getDocumentElement : $feed->{doc};
+    if (@_) {
+        $elem->setAttribute('version', $_[0]);
+    }
+    $elem->getAttribute('version');
+}
+
+sub entries_libxml {
+    my $feed = shift;
+    my @res = $feed->{doc}->getElementsByTagNameNS(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->{doc}->find("descendant-or-self::*[local-name()='entry' and namespace-uri()='" . 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' => 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) = @_;
+    $feed->{doc}->getDocumentElement->appendChild($entry->{doc}->getDocumentElement);
+}
+
+sub add_entry_xpath {
+    my $feed = shift;
+    my($entry) = @_;
+    $feed->{doc}->appendChild($entry->{doc});
+}
+
+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');
+    my $entry = XML::Atom::Entry->new;
+    $entry->title('First Post');
+    $entry->content('Post Body');
+    $feed->add_entry($entry);
+    my @entries = $feed->entries;
+    my $xml = $feed->as_xml;
+
+    ## Get a list of the <link rel="..." /> 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<XML::Atom::Feed> object. On failure, returns C<undef>.
+
+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<text/html>, this method will automatically try to perform auto-discovery
+by looking for a I<E<lt>linkE<gt>> 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 I<E<lt>linkE<gt>> tags).
+
+Returns a list of feed URIs. 
+
+=head2 $feed->link
+
+If called in scalar context, returns an I<XML::Atom::Link> object
+corresponding to the first I<E<lt>linkE<gt>> tag found in the feed.
+
+If called in list context, returns a list of I<XML::Atom::Link> objects
+corresponding to all of the I<E<lt>linkE<gt>> tags found in the feed.
+
+=head2 $feed->add_link($link)
+
+Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
+the feed as a new I<E<lt>linkE<gt>> 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->language
+
+Returns the language of the feed, from I<xml:lang>.
+
+=head2 $feed->author([ $author ])
+
+Returns an I<XML::Atom::Person> object representing the author of the entry,
+or C<undef> if there is no author information present.
+
+If I<$author> is supplied, it should be an I<XML::Atom::Person> object
+representing the author. For example:
+
+    my $author = XML::Atom::Person->new;
+    $author->name('Foo Bar');
+    $author->email('foo@bar.com');
+    $feed->author($author);
+
+=head1 AUTHOR & COPYRIGHT
+
+Please see the I<XML::Atom> manpage for author, copyright, and license
+information.
+
+=cut

livejournal/cgi-bin/XML/Atom/Link.pm

@@ -0,0 +1,92 @@
+# $Id: Link.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Link;
+use strict;
+
+use XML::Atom;
+use base qw( XML::Atom::ErrorHandler );
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+sub new {
+    my $class = shift;
+    my $link = bless {}, $class;
+    $link->init(@_) or return $class->error($link->errstr);
+    $link;
+}
+
+sub init {
+    my $link = shift;
+    my %param = @_ == 1 ? (Body => $_[0]) : @_;
+    my $elem;
+    unless ($elem = $param{Elem}) {
+        if (LIBXML) {
+            my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
+            $elem = $doc->createElementNS(NS, 'link');
+            $doc->setDocumentElement($elem);
+        } else {
+            $elem = XML::XPath::Node::Element->new('link');
+            my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
+            $elem->appendNamespace($ns);
+        }
+    }
+    $link->{elem} = $elem;
+    $link;
+}
+
+sub elem { $_[0]->{elem} }
+
+sub get {
+    my $link = shift;
+    my($attr) = @_;
+    my $val = $link->elem->getAttribute($attr);
+    if ($] >= 5.008) {
+        require Encode;
+        Encode::_utf8_off($val);
+    }
+    $val;
+}
+
+sub set {
+    my $link = shift;
+    if (@_ == 2) {
+	my($attr, $val) = @_;
+	$link->elem->setAttribute($attr, $val);
+    } elsif (@_ == 3) {
+	my($ns, $attr, $val) = @_;
+	my $attribute = "$ns->{prefix}:$attr";
+	if (LIBXML) {
+	    $link->elem->setAttributeNS($ns->{uri}, $attribute, $val);
+	} else {
+	    my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
+            $link->elem->appendNamespace($ns);
+	    $link->elem->setAttribute($attribute => $val);
+	}
+    }
+}
+
+sub as_xml {
+    my $link = shift;
+    if (LIBXML) {
+        my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
+        $doc->setDocumentElement($link->elem);
+        return $doc->toString(1);
+    } else {
+        return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
+            $link->elem->toString;
+    }
+}
+
+sub DESTROY { }
+
+use vars qw( $AUTOLOAD );
+sub AUTOLOAD {
+    (my $var = $AUTOLOAD) =~ s!.+::!!;
+    no strict 'refs';
+    *$AUTOLOAD = sub {
+        @_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
+    };
+    goto &$AUTOLOAD;
+}
+
+1;

livejournal/cgi-bin/XML/Atom/Person.pm

@@ -0,0 +1,120 @@
+# $Id: Person.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Person;
+use strict;
+
+use XML::Atom;
+use base qw( XML::Atom::ErrorHandler );
+use XML::Atom::Util qw( first );
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+sub new {
+    my $class = shift;
+    my $person = bless {}, $class;
+    $person->init(@_) or return $class->error($person->errstr);
+    $person;
+}
+
+sub init {
+    my $person = shift;
+    my %param = @_;
+    my $elem;
+    unless ($elem = $param{Elem}) {
+        if (LIBXML) {
+            my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
+            $elem = $doc->createElementNS(NS, 'author'); ## xxx
+            $doc->setDocumentElement($elem);
+        } else {
+            $elem = XML::XPath::Node::Element->new('author'); ## xxx
+            my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
+            $elem->appendNamespace($ns);
+        }
+    }
+    $person->{elem} = $elem;
+    $person;
+}
+
+sub elem { $_[0]->{elem} }
+
+sub get {
+    my $person = shift;
+    my($name) = @_;
+    my $node = first($person->elem, NS, $name) or return;
+    my $val = LIBXML ? $node->textContent : $node->string_value;
+    if ($] >= 5.008) {
+        require Encode;
+        Encode::_utf8_off($val);
+    }
+    $val;
+}
+
+sub set {
+    my $person = shift;
+    my($name, $val) = @_;
+    my $elem;
+    unless ($elem = first($person->elem, NS, $name)) {
+        if (LIBXML) {
+            $elem = XML::LibXML::Element->new($name);
+            $elem->setNamespace(NS);
+        } else {
+            $elem = XML::XPath::Node::Element->new($name);
+            my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
+            $elem->appendNamespace($ns);
+        }
+        $person->elem->appendChild($elem);
+    }
+    if (LIBXML) {
+        $elem->removeChildNodes;
+        $elem->appendChild(XML::LibXML::Text->new($val));
+    } else {
+        $elem->removeChild($_) for $elem->getChildNodes;
+        $elem->appendChild(XML::XPath::Node::Text->new($val));
+    }
+    $val;
+}
+
+sub as_xml {
+    my $person = shift;
+    if (LIBXML) {
+        my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
+        $doc->setDocumentElement($person->elem);
+        return $doc->toString(1);
+    } else {
+        return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
+            $person->elem->toString;
+    }
+}
+
+sub DESTROY { }
+
+use vars qw( $AUTOLOAD );
+sub AUTOLOAD {
+    (my $var = $AUTOLOAD) =~ s!.+::!!;
+    no strict 'refs';
+    *$AUTOLOAD = sub {
+        @_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
+    };
+    goto &$AUTOLOAD;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XML::Atom::Person - Author or contributor object
+
+=head1 SYNOPSIS
+
+    my $author = XML::Atom::Person->new;
+    $author->email('foo@example.com');
+    $author->name('Foo Bar');
+    $entry->author($author);
+
+=head1 DESCRIPTION
+
+I<XML::Atom::Person> represents an author or contributor element in an
+Atom feed or entry.
+
+=cut

livejournal/cgi-bin/XML/Atom/Server.pm

@@ -0,0 +1,538 @@
+# $Id: Server.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+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 = <<SOAP;
+$1
+<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
+  <soap:Body>$out</soap:Body>
+</soap:Envelope>
+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 <<FAULT;
+<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
+  <soap:Body>
+    <soap:Fault>
+      <faultcode>$code</faultcode>
+      <faultstring>$err</faultstring>
+    </soap:Fault>
+  </soap:Body>
+</soap:Envelope>
+FAULT
+    } else {
+        return <<ERR;
+<?xml version="1.0" encoding="utf-8"?>
+<error>$err</error>
+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 = XML::LibXML->new;
+            $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;
+}
+
+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 = $app->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<XML::Atom::Server> 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<XML::Atom::Server>, overriding the
+I<handle_request> method, and handle all functions such as this themselves.
+
+=head1 SUBCLASSING
+
+=head2 Request Handling
+
+Subclasses of I<XML::Atom::Server> must override the I<handle_request>
+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 => $app->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<password_for_user> method. Given a username
+(from the WSSE header), I<password_for_user> 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<undef>.
+
+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<XML::Atom::Server> 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<GET>, C<POST>, etc). Note that if the client sent the
+request in a SOAP envelope, the method is obtained from the I<SOAPAction>
+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<XML::Atom::Server> 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<entry_id> parameter would be set to C<1>.
+
+I<request_param> 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<Content-Type> 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<password_for_user> method in the subclass to obtain the cleartext
+password for the username given in the request.
+
+=item * $server->atom_body
+
+Returns an I<XML::Atom::Entry> 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
+    <Location /atom-server>
+        SetHandler perl-script
+        PerlHandler My::Server
+    </Location>
+
+=head1 ERROR HANDLING
+
+If you wish to return an error from I<handle_request>, you can use the
+built-in I<error> 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<Something went wrong>. Errors are automatically
+serialized into SOAP faults if the incoming request is enclosed in a SOAP
+envelope.
+
+=head1 AUTHOR & COPYRIGHT
+
+Please see the I<XML::Atom> manpage for author, copyright, and license
+information.
+
+=cut

livejournal/cgi-bin/XML/Atom/Thing.pm

@@ -0,0 +1,322 @@
+# $Id: Thing.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Thing;
+use strict;
+
+use XML::Atom;
+use base qw( XML::Atom::ErrorHandler );
+use XML::Atom::Util qw( first nodelist remove_default_ns );
+use XML::Atom::Link;
+use LWP::UserAgent;
+BEGIN {
+    if (LIBXML) {
+        *init = \&init_libxml;
+        *set = \&set_libxml;
+        *link = \&link_libxml;
+    } else {
+        *init = \&init_xpath;
+        *set = \&set_xpath;
+        *link = \&link_xpath;
+    }
+}
+
+use constant NS => 'http://purl.org/atom/ns#';
+
+sub new {
+    my $class = shift;
+    my $atom = bless {}, $class;
+    $atom->init(@_) or return $class->error($atom->errstr);
+    $atom;
+}
+
+sub init_libxml {
+    my $atom = shift;
+    my %param = @_ == 1 ? (Stream => $_[0]) : @_;
+    if (%param) {
+        if (my $stream = $param{Stream}) {
+            my $parser = XML::LibXML->new;
+            if (ref($stream) eq 'SCALAR') {
+                $atom->{doc} = $parser->parse_string($$stream);
+            } elsif (ref($stream)) {
+                $atom->{doc} = $parser->parse_fh($stream);
+            } else {
+                $atom->{doc} = $parser->parse_file($stream);
+            }
+        } elsif (my $doc = $param{Doc}) {
+            $atom->{doc} = $doc;
+        } elsif (my $elem = $param{Elem}) {
+            $atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
+            $atom->{doc}->setDocumentElement($elem);
+        }
+    } else {
+        my $doc = $atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
+        my $root = $doc->createElementNS(NS, $atom->element_name);
+        $doc->setDocumentElement($root);
+    }
+    $atom;
+}
+
+sub init_xpath {
+    my $atom = shift;
+    my %param = @_ == 1 ? (Stream => $_[0]) : @_;
+    my $elem_name = $atom->element_name;
+    if (%param) {
+        if (my $stream = $param{Stream}) {
+            my $xp;
+            if (ref($stream) eq 'SCALAR') {
+                $xp = XML::XPath->new(xml => $$stream);
+            } elsif (ref($stream)) {
+                $xp = XML::XPath->new(ioref => $stream);
+            } else {
+                $xp = XML::XPath->new(filename => $stream);
+            }
+            my $set = $xp->find('/' . $elem_name);
+            unless ($set && $set->size) {
+                $set = $xp->find('/');
+            }
+            $atom->{doc} = ($set->get_nodelist)[0];
+        } elsif (my $doc = $param{Doc}) {
+            $atom->{doc} = $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('/');
+            }
+            $atom->{doc} = ($set->get_nodelist)[0];
+        }
+    } else {
+        my $xp = XML::XPath->new;
+        $xp->set_namespace(atom => NS);
+        $atom->{doc} = XML::XPath::Node::Element->new($atom->element_name);
+        my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
+        $atom->{doc}->appendNamespace($ns);
+    }
+    $atom;
+}
+
+sub get {
+    my $atom = shift;
+    my($ns, $name) = @_;
+    my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
+    my $node = first($atom->{doc}, $ns_uri, $name);
+    return unless $node;
+    my $val = LIBXML ? $node->textContent : $node->string_value;
+    if ($] >= 5.008) {
+        require Encode;
+        Encode::_utf8_off($val);
+    }
+    $val;
+}
+
+sub getlist {
+    my $atom = shift;
+    my($ns, $name) = @_;
+    my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
+    my @node = nodelist($atom->{doc}, $ns_uri, $name);
+     map {
+        my $val = LIBXML ? $_->textContent : $_->string_value;
+        if ($] >= 5.008) {
+            require Encode;
+            Encode::_utf8_off($val);
+        }
+        $val;
+     } @node;
+}
+
+sub set_libxml {
+    my $atom = shift;
+    my($ns, $name, $val, $attr) = @_;
+    my $elem;
+    my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
+    unless ($elem = first($atom->{doc}, $ns_uri, $name)) {
+        $elem = $atom->{doc}->createElementNS($ns_uri, $name);
+        $atom->{doc}->getDocumentElement->appendChild($elem);
+    }
+    if ($ns ne NS) {
+        $atom->{doc}->getDocumentElement->setNamespace($ns->{uri}, $ns->{prefix}, 0);
+    }
+    if (ref($val) =~ /Element$/) {
+        $elem->appendChild($val);
+    } elsif (defined $val) {
+        $elem->removeChildNodes;
+        my $text = XML::LibXML::Text->new($val);
+        $elem->appendChild($text);
+    }
+    if ($attr) {
+        while (my($k, $v) = each %$attr) {
+            $elem->setAttribute($k, $v);
+        }
+    }
+    $val;
+}
+
+sub set_xpath {
+    my $atom = shift;
+    my($ns, $name, $val, $attr) = @_;
+    my $elem;
+    my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
+    unless ($elem = first($atom->{doc}, $ns_uri, $name)) {
+        $elem = XML::XPath::Node::Element->new($name);
+        if ($ns ne NS) {
+            my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
+            $elem->appendNamespace($ns);
+        }
+        $atom->{doc}->appendChild($elem);
+    }
+    if (ref($val) =~ /Element$/) {
+        $elem->appendChild($val);
+    } elsif (defined $val) {
+        $elem->removeChild($_) for $elem->getChildNodes;
+        my $text = XML::XPath::Node::Text->new($val);
+        $elem->appendChild($text);
+    }
+    if ($attr) {
+        while (my($k, $v) = each %$attr) {
+            $elem->setAttribute($k, $v);
+        }
+    }
+    $val;
+}
+
+sub add_link {
+    my $thing = shift;
+    my($link) = @_;
+    my $elem;
+    if (ref($link) eq 'XML::Atom::Link') {
+	if (LIBXML) {
+	    $thing->{doc}->getDocumentElement->appendChild($link->elem);
+	} else {
+	    $thing->{doc}->appendChild($link->elem);
+	}
+    } else {
+	if (LIBXML) {
+	    $elem = $thing->{doc}->createElementNS(NS, 'link');
+	    $thing->{doc}->getDocumentElement->appendChild($elem);
+	} else {
+	    $elem = XML::XPath::Node::Element->new('link');
+	    my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
+	    $elem->appendNamespace($ns);
+	    $thing->{doc}->appendChild($elem);
+	}
+    }
+    if (ref($link) eq 'HASH') {
+        for my $k (qw( type rel href title )) {
+            my $v = $link->{$k} or next;
+            $elem->setAttribute($k, $v);
+        }
+    }
+}
+
+sub link_libxml {
+    my $thing = shift;
+    if (wantarray) {
+        my @res = $thing->{doc}->getDocumentElement->getChildrenByTagNameNS(NS, 'link');
+        my @links;
+        for my $elem (@res) {
+            push @links, XML::Atom::Link->new(Elem => $elem);
+        }
+        return @links;
+    } else {
+        my $elem = first($thing->{doc}, NS, 'link') or return;
+        return XML::Atom::Link->new(Elem => $elem);
+    }
+}
+
+sub link_xpath {
+    my $thing = shift;
+    if (wantarray) {
+        my $set = $thing->{doc}->find("*[local-name()='link' and namespace-uri()='" . NS . "']");
+        my @links;
+        for my $elem ($set->get_nodelist) {
+            push @links, XML::Atom::Link->new(Elem => $elem);
+        }
+        return @links;
+    } else {
+        my $elem = first($thing->{doc}, NS, 'link') or return;
+        return XML::Atom::Link->new(Elem => $elem);
+    }
+}
+
+sub author {
+    my $thing = shift;
+    $thing->_element('XML::Atom::Person', 'author', @_);
+}
+
+sub as_xml {
+    my $doc = $_[0]->{doc};
+    if (eval { require XML::LibXSLT }) {
+        my $parser = XML::LibXML->new;
+        my $xslt = XML::LibXSLT->new;
+        my $style_doc = $parser->parse_string(<<'EOX');
+<?xml version="1.0"?>
+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
+  <xsl:template match="@*|node()">
+    <xsl:copy>
+      <xsl:apply-templates select="@*|node()"/>
+    </xsl:copy>
+  </xsl:template>
+</xsl:stylesheet> 
+EOX
+        my $sheet = $xslt->parse_stylesheet($style_doc);
+        my $results = $sheet->transform($doc);
+        return $sheet->output_string($results);
+    } else {
+        remove_default_ns($doc->getDocumentElement);
+        return $doc->toString(LIBXML ? 1 : 0);
+    }
+}
+
+sub _element {
+    my $thing = shift;
+    my($class, $name) = (shift, shift);
+    my $root = LIBXML ? $thing->{doc}->getDocumentElement : $thing->{doc};
+    if (@_) {
+        my $obj = shift;
+        if (my $node = first($thing->{doc}, NS, $name)) {
+            $root->removeChild($node);
+        }
+        my $elem = LIBXML ?
+            $thing->{doc}->createElementNS(NS, $name) :
+            XML::XPath::Node::Element->new($name);
+        $root->appendChild($elem);
+        if (LIBXML) {
+            for my $child ($obj->elem->childNodes) {
+                $elem->appendChild($child->cloneNode(1));
+            }
+            for my $attr ($obj->elem->attributes) {
+                next unless ref($attr) eq 'XML::LibXML::Attr';
+                $elem->setAttribute($attr->getName, $attr->getValue);
+            }
+        } else {
+            for my $child ($obj->elem->getChildNodes) {
+                $elem->appendChild($child);
+            }
+            for my $attr ($obj->elem->getAttributes) {
+                $elem->appendAttribute($attr);
+            }
+        }
+        $obj->{elem} = $elem;
+        $thing->{'__' . $name} = $obj;
+    } else {
+        unless (exists $thing->{'__' . $name}) {
+            my $elem = first($thing->{doc}, NS, $name) or return;
+            $thing->{'__' . $name} = $class->new(Elem => $elem);
+        }
+    }
+    $thing->{'__' . $name};
+}
+
+sub DESTROY { }
+
+use vars qw( $AUTOLOAD );
+sub AUTOLOAD {
+    (my $var = $AUTOLOAD) =~ s!.+::!!;
+    no strict 'refs';
+    *$AUTOLOAD = sub {
+        @_ > 1 ? $_[0]->set(NS, $var, @_[1..$#_]) : $_[0]->get(NS, $var)
+    };
+    goto &$AUTOLOAD;
+}
+
+1;

livejournal/cgi-bin/XML/Atom/Util.pm

@@ -0,0 +1,106 @@
+# $Id: Util.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
+
+package XML::Atom::Util;
+use strict;
+
+use XML::Atom;
+use vars qw( @EXPORT_OK @ISA );
+use Exporter;
+@EXPORT_OK = qw( first nodelist textValue iso2dt encode_xml remove_default_ns );
+@ISA = qw( Exporter );
+
+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 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 = ('&' => '&amp;', '"' => '&quot;', '<' => '&lt;', '>' => '&gt;',
+           '\'' => '&apos;');
+my $RE = join '|', keys %Map;
+
+sub encode_xml {
+    my($str) = @_;
+    $str =~ s!($RE)!$Map{$1}!g;
+    $str;
+}
+
+sub remove_default_ns {
+    my($node) = @_;
+    $node->setNamespace('http://www.w3.org/1999/xhtml', '')
+        if $node->nodeName =~ /^default:/ && ref($node) =~ /Element$/;
+    for my $n ($node->childNodes) {
+        remove_default_ns($n);
+    }
+}
+
+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<DateTime> object and returns
+the I<DateTime> 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<XML::Atom> manpage for author, copyright, and license
+information.
+
+=cut