Changeset 1784

Show
Ignore:
Timestamp:
11/19/07 17:56:22 (6 years ago)
Author:
mattn
Message:

lang/perl/XML-Atom-Server-Lite/trunk/TODO,
lang/perl/XML-Atom-Server-Lite/trunk/MANIFEST,
lang/perl/XML-Atom-Server-Lite/trunk/lib/XML/Atom/Server/Lite.pm,
lang/perl/XML-Atom-Server-Lite/trunk/lib/XML/Atom/Server/Lite,
lang/perl/XML-Atom-Server-Lite/trunk/lib/XML/Atom/Server/Lite/Entry.pm,
lang/perl/XML-Atom-Server-Lite/trunk/lib/XML/Atom/Server/Lite/Feed.pm,
lang/perl/XML-Atom-Server-Lite/trunk/Changes:

removed dependencies on XML::Atom::Server.
(but this module does not support SOAP method yet.)

Location:
lang/perl/XML-Atom-Server-Lite/trunk
Files:
3 added
4 modified

Legend:

Unmodified
Added
Removed

  • lang/perl/XML-Atom-Server-Lite/trunk/Changes

    r1384 r1784  
    11Revision history for Perl extension XML::Atom::Server::Lite 
     2 
     30.02  Mon Nov 19 17:45:55 2007 
     4        - removed dependencies on XML::Atom::Server. 
    25 
    360.01  Tue Nov 13 17:39:18 2007 

  • lang/perl/XML-Atom-Server-Lite/trunk/MANIFEST

    r1384 r1784  
    1717inc/Test/More.pm 
    1818lib/XML/Atom/Server/Lite.pm 
     19lib/XML/Atom/Server/Lite/Entry.pm 
     20lib/XML/Atom/Server/Lite/Feed.pm 
    1921Makefile.PL 
    2022MANIFEST                        This list of files 

  • lang/perl/XML-Atom-Server-Lite/trunk/TODO

    r1386 r1784  
    1 remove dependencies on XML::Atom or XML::Atom::Server. 
     1- remove dependencies on XML::Atom or XML::Atom::Server. 
     2* support SOAP method. 

  • lang/perl/XML-Atom-Server-Lite/trunk/lib/XML/Atom/Server/Lite.pm

    r1384 r1784  
    33use strict; 
    44use 5.8.1; 
    5 our $VERSION = '0.01'; 
    6  
    7 use base qw( XML::Atom::Server ); 
     5our $VERSION = '0.02'; 
     6 
     7use MIME::Base64 qw( encode_base64 decode_base64 ); 
    88use Digest::SHA::PurePerl qw( sha1 ); 
    99use XML::Parser::Lite::Tree; 
     10use XML::Atom::Server::Lite::Feed; 
     11use XML::Atom::Server::Lite::Entry; 
     12 
     13sub new { 
     14    my $class = shift; 
     15    my $server = bless { }, $class; 
     16    $server->init(@_) or return $class->error($server->errstr); 
     17    $server; 
     18} 
     19 
     20sub init { 
     21    my $server = shift; 
     22    $server->{param} = {}; 
     23    unless ($ENV{MOD_PERL}) { 
     24        require CGI; 
     25        $server->{cgi} = CGI->new({}); 
     26    } 
     27    $server; 
     28} 
    1029 
    1130my %esc = (   
    … …  
    6483        for my $item (@{$tree->{children}}) { 
    6584            if ($item->{name} eq 'div' && $item->{attributes} 
    66                                 && %{$item->{attributes}}->{xmlns} =~ 'http://www.w3.org/1999/xhtml') { 
     85                && {$item->{attributes}}->{xmlns} =~ 'http://www.w3.org/1999/xhtml') { 
    6786                $tree = $item; 
    68                                 for my $nobr (@{$tree->{children}}) { 
    69                                         return $nobr if $nobr->{name} ne 'br' && $nobr->{type} eq 'tag'; 
    70                                 } 
     87                for my $nobr (@{$tree->{children}}) { 
     88                    return $nobr if $nobr->{name} ne 'br' && $nobr->{type} eq 'tag'; 
     89                } 
    7190                last; 
    7291            } 
    … …  
    102121    my $server = shift; 
    103122    unless (exists $server->{xml_body}) { 
    104                 $server->{xml_body} = XML::Parser::Lite::Tree->new(xml => $server->request_content); 
     123        $server->{xml_body} = XML::Parser::Lite::Tree->new(xml => $server->request_content); 
    105124    } 
    106125    $server->{xml_body}; 
    … …  
    110129    my $server = shift; 
    111130    my $atom; 
    112         my $tree_parser = XML::Parser::Lite::Tree::instance(); 
    113         my $tree = $tree_parser->parse( $server->request_content ); 
    114         my $items = $tree->{children}->[0]->{children}; 
    115  
    116         $atom = XML::Atom::Entry->new; 
    117         foreach my $item (@{$items}) { 
    118                 if ($item->{name} eq 'title') { 
    119                         $atom->title($item->{children}->[0]->{content}); 
    120                 } 
    121                 if ($item->{name} eq 'content') { 
    122                         my $content = XML::Atom::Content->new; 
    123                         my $data = to_xml(get_content_node($item)); 
    124                         $content->mode($item->{children}->[0]->{mode}); 
    125                         $content->type($item->{children}->[0]->{type}); 
    126                         $content->body($data); 
    127                         $atom->content($content); 
    128                 } 
    129                 if ($item->{name} eq 'category') { 
    130                         my $category = XML::Atom::Category->new; 
    131                         $category->term($item->{attributes}->{term}); 
    132                         $category->label($item->{attributes}->{label}); 
    133                         $atom->category($category); 
    134                 } 
    135                 if ($item->{name} eq 'link') { 
    136                         my $link = XML::Atom::Link->new; 
    137                         $link->rel($item->{attributes}->{type}); 
    138                         $link->type($item->{attributes}->{type}); 
    139                         $link->href($item->{attributes}->{href}); 
    140                         $atom->add_link( $link ); 
    141                 } 
    142                 if ($item->{name} eq 'category') { 
    143                         my $category = XML::Atom::Category->new; 
    144                         $category->term($item->{attributes}->{term}); 
    145                         $category->label($item->{attributes}->{label}); 
    146                         $atom->category($category); 
    147                 } 
    148                 if ($item->{name} eq 'subject') { 
    149                         my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/'); 
    150                         for my $sub (@{$item->{children}}) { 
    151                                 $atom->add($dc, 'subject', $sub->{content}); 
    152                         } 
    153                 } 
     131    my $tree_parser = XML::Parser::Lite::Tree::instance(); 
     132    my $tree = $tree_parser->parse( $server->request_content ); 
     133    my $items = $tree->{children}->[0]->{children}; 
     134 
     135    $atom = XML::Atom::Server::Lite::Entry->new; 
     136    foreach my $item (@{$items}) { 
     137        if ($item->{name} eq 'title') { 
     138            $atom->title($item->{children}->[0]->{content}); 
     139        } 
     140        if ($item->{name} eq 'content') { 
     141            my $content = {}; 
     142            my $data = to_xml(get_content_node($item)); 
     143            $content->{mode} = $item->{children}->[0]->{mode}; 
     144            $content->{type} = $item->{children}->[0]->{type}; 
     145            $content->{body} = $data; 
     146            $atom->content($content); 
     147        } 
     148        if ($item->{name} eq 'category') { 
     149            my $category = {}; 
     150            $category->{term} = $item->{attributes}->{term}; 
     151            $category->{label} = $item->{attributes}->{label}; 
     152            $atom->category($category); 
     153        } 
     154        if ($item->{name} eq 'link') { 
     155            my $link = {}; 
     156            $link->{rel} = $item->{attributes}->{type}; 
     157            $link->{type} = $item->{attributes}->{type}; 
     158            $link->{href} = $item->{attributes}->{href}; 
     159            $atom->link($link); 
     160        } 
     161        if ($item->{name} eq 'dc:subject') { 
     162            for my $sub (@{$item->{children}}) { 
     163                $atom->subject($sub->{content}); 
     164            } 
     165        } 
    154166    } 
    155167    $atom; 
     168} 
     169 
     170sub run { 
     171    my $server = shift; 
     172    (my $pi = $server->path_info) =~ s!^/!!; 
     173    my @args = split /\//, $pi; 
     174    for my $arg (@args) { 
     175        my($k, $v) = split /=/, $arg, 2; 
     176        $server->request_param($k, $v); 
     177    } 
     178    my $out; 
     179    eval { 
     180        defined($out = $server->handle_request) or die $server->errstr; 
     181    }; 
     182    if ($@) { 
     183        $out = $server->show_error($@); 
     184    } 
     185    $server->send_http_header; 
     186    $server->print($out); 
     187    1; 
     188} 
     189 
     190sub request_param { 
     191    my $server = shift; 
     192    my $k = shift; 
     193    $server->{param}{$k} = shift if @_; 
     194    $server->{param}{$k}; 
     195} 
     196 
     197sub request_header { 
     198    my $server = shift; 
     199    my($key) = @_; 
     200    if ($ENV{MOD_PERL}) { 
     201        return $server->{apache}->header_in($key); 
     202    } else { 
     203        ($key = uc($key)) =~ tr/-/_/; 
     204        return $ENV{'HTTP_' . $key}; 
     205    } 
     206} 
     207 
     208sub request_method { 
     209    my $server = shift; 
     210    if (@_) { 
     211        $server->{request_method} = shift; 
     212    } elsif (!exists $server->{request_method}) { 
     213        $server->{request_method} = 
     214            $ENV{MOD_PERL} ? $server->{apache}->method : $ENV{REQUEST_METHOD}; 
     215    } 
     216    $server->{request_method}; 
     217} 
     218 
     219sub request_content { 
     220    my $server = shift; 
     221    unless (exists $server->{request_content}) { 
     222        if ($ENV{MOD_PERL}) { 
     223            ## Read from $server->{apache} 
     224            my $r = $server->{apache}; 
     225            my $len = $server->request_header('Content-length'); 
     226            $r->read($server->{request_content}, $len); 
     227        } else { 
     228            ## Read from STDIN 
     229            my $len = $ENV{CONTENT_LENGTH} || 0; 
     230            read STDIN, $server->{request_content}, $len; 
     231        } 
     232    } 
     233    $server->{request_content}; 
     234} 
     235 
     236sub path_info { 
     237    my $server = shift; 
     238    return $server->{__path_info} if exists $server->{__path_info}; 
     239    my $path_info; 
     240    if ($ENV{MOD_PERL}) { 
     241        ## mod_perl often leaves part of the script name (Location) 
     242        ## in the path info, for some reason. This should remove it. 
     243        $path_info = $server->{apache}->path_info; 
     244        if ($path_info) { 
     245            my($script_last) = $server->{apache}->location =~ m/\/([^\/]+)$/; 
     246            $path_info =~ s/^\/$script_last//; 
     247        } 
     248    } else { 
     249        $path_info = $server->{cgi}->path_info; 
     250    } 
     251    $server->{__path_info} = $path_info; 
     252} 
     253 
     254sub get_auth_info { 
     255    my $server = shift; 
     256    my %param; 
     257    my $req = $server->request_header('X-WSSE') 
     258        or return $server->auth_failure(401, 'X-WSSE authentication required'); 
     259    $req =~ s/^(?:WSSE|UsernameToken) //; 
     260    for my $i (split /,\s*/, $req) { 
     261        my($k, $v) = split /=/, $i, 2; 
     262        $v =~ s/^"//; 
     263        $v =~ s/"$//; 
     264        $param{$k} = $v; 
     265    } 
     266    \%param; 
     267} 
     268 
     269sub authenticate { 
     270    my $server = shift; 
     271    my $auth = $server->get_auth_info or return; 
     272    for my $f (qw( Username PasswordDigest Nonce Created )) { 
     273        return $server->auth_failure(400, "X-WSSE requires $f") 
     274            unless $auth->{$f}; 
     275    } 
     276    my $password = $server->password_for_user($auth->{Username}); 
     277    defined($password) or return $server->auth_failure(403, 'Invalid login'); 
     278    my $expected = encode_base64(sha1( 
     279           decode_base64($auth->{Nonce}) . $auth->{Created} . $password 
     280    ), ''); 
     281    return $server->auth_failure(403, 'Invalid login') 
     282        unless $expected eq $auth->{PasswordDigest}; 
     283    return 1; 
     284} 
     285 
     286sub auth_failure { 
     287    my $server = shift; 
     288    $server->response_header('WWW-Authenticate', 'WSSE profile="UsernameToken"'); 
     289    return $server->error(@_); 
     290} 
     291 
     292my %Map = ('&' => '&amp;', '"' => '&quot;', '<' => '&lt;', '>' => '&gt;', 
     293           '\'' => '&apos;'); 
     294my $RE = join '|', keys %Map; 
     295sub encode_xml { 
     296    my($str) = @_; 
     297    $str =~ s!($RE)!$Map{$1}!g; 
     298    $str; 
     299} 
     300 
     301sub error { 
     302    my $server = shift; 
     303    my($code, $msg) = @_; 
     304    $server->response_code($code) if ref($server); 
     305    return $server->_error($msg); 
     306} 
     307 
     308use vars qw( $ERROR ); 
     309sub _error  { 
     310    my $msg = $_[1] || ''; 
     311    $msg .= "\n" unless $msg =~ /\n$/; 
     312    if (ref($_[0])) { 
     313        $_[0]->{_errstr} = $msg; 
     314    } else { 
     315        $ERROR = $msg; 
     316    } 
     317    return; 
     318} 
     319 
     320sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR } 
     321 
     322sub show_error { 
     323    my $server = shift; 
     324    my($err) = @_; 
     325    chomp($err = encode_xml($err)); 
     326    return <<ERR; 
     327<?xml version="1.0" encoding="utf-8"?> 
     328<error>$err</error> 
     329ERR 
     330} 
     331 
     332sub response_header { 
     333    my $server = shift; 
     334    my($key, $val) = @_; 
     335    if ($ENV{MOD_PERL}) { 
     336        $server->{apache}->header_out($key, $val); 
     337    } else { 
     338        unless ($key =~ /^-/) { 
     339            ($key = lc($key)) =~ tr/-/_/; 
     340            $key = '-' . $key; 
     341        } 
     342        $server->{cgi_headers}{$key} = $val; 
     343    } 
     344} 
     345 
     346sub response_code { 
     347    my $server = shift; 
     348    $server->{response_code} = shift if @_; 
     349    $server->{response_code}; 
     350} 
     351 
     352sub response_content_type { 
     353    my $server = shift; 
     354    $server->{response_content_type} = shift if @_; 
     355    $server->{response_content_type}; 
     356} 
     357sub send_http_header { 
     358    my $server = shift; 
     359    my $type = $server->response_content_type || 'application/x.atom+xml'; 
     360    if ($ENV{MOD_PERL}) { 
     361        $server->{apache}->status($server->response_code || 200); 
     362        $server->{apache}->send_http_header($type); 
     363    } else { 
     364        $server->{cgi_headers}{-status} = $server->response_code || 200; 
     365        $server->{cgi_headers}{-type} = $type; 
     366        print $server->{cgi}->header(%{ $server->{cgi_headers} }); 
     367    } 
     368} 
     369 
     370sub print { 
     371    my $server = shift; 
     372    if ($ENV{MOD_PERL}) { 
     373        $server->{apache}->print(@_); 
     374    } else { 
     375        CORE::print(@_); 
     376    } 
    156377} 
    157378