2008/04/03


追記
ゆーすけべーさんのほうで、最終引数をパスではなくオプションハッシュにする対応を入れて頂きました。 これにより以下のパッチを当てなくても動的にメソッドパスを設定出来る様になりました。ゆーすけべーさんにはサンプルも変更に対応して頂き、さらにはパッケージに含んで頂いたようです。
yusukebe++
修正されたソースは
http://coderepos.org/share/browser/lang/perl/WebService-Simple/trunk/example/lingr.pl
より参照下さい。以下、パッチも一応残しておきますが当たりませんのでお気をつけ下さい。サンプルは入れ替えておきました。

便利だなぁ。
ゆーすけべー日記: POX over HTTP のウェブAPIにアクセスするためのモジュール「WebService::Simple」を作ってみた

俗に言う「POX over HTTP」のウェブAPIにアクセスするためのシンプルな(?)Perlモジュール「WebService::Simple」なるものを作ってみました。

ゆーすけべー日記: WebService::Simple でキャッシュできるようにしたよ

dannさんから「WebService::Simpleで(取得したコンテンツを)キャッシュしたいよ!」と言われて、俺もその機能欲しかったので追加しました。

flickrとか簡単に扱えてしかもキャッシュ機能もある。1セッション当たりにサーバへのアクセス数が多いサービスでは重宝するんじゃないかな。で、試そうかと思ったんですが、ベースURLが固定なRESTサービス(methodパラメータとか無い物)って案外無い。どっちかっていうと、URLにメソッドを含んでいる物が多い。そうした場合、メソッド単位でURLを変えなきゃいけない。って事でちょっとだけ改造してみました。
この変更は別の方法で取り込まれました。
Index: lib/WebService/Simple.pm
===================================================================
--- lib/WebService/Simple.pm    (revision 8637)
+++ lib/WebService/Simple.pm    (working copy)
@@ -3,9 +3,9 @@
 use warnings;
 use strict;
 use Carp;
+use URI;
 use URI::Escape;
 use LWP::UserAgent;
-use URI::Escape;
 use WebService::Simple::Response;
 
 our $VERSION = '0.02';
@@ -21,8 +21,8 @@
 }
 
 sub get {
-    my ($self, $request_param) = @_;
-    my $url = $self->_make_url($request_param);
+    my ($self, $request_param, $path) = @_;
+    my $url = $self->_make_url($request_param, $path);
     my $response = $self->_fetch_url($url);
     return $response;
 }
@@ -44,14 +44,21 @@
     return $response;
 }
 sub _make_url{
-    my ($self, $request_param) = @_;
+    my ($self, $request_param, $path) = @_;
     my $base_url = $self->{base_url};
     my $url = $base_url =~ /\?$/ ? $base_url : $base_url . "?";
     my @params;
     push(@params, $self->_hashref_to_str($self->{param}));
     push(@params, $self->_hashref_to_str($request_param));
-    my $str = join("&",@params);
-    return $url . $str;
+    $url .= join("&",@params);
+    if ($path) {
+        # append additional path.
+        my $u = URI->new( $url );
+        $path =~ s!^/!! if $u->path =~ /\/$/;
+        $u->path( $u->path . $path );
+        $url = $u->as_string;
+    }
+    return $url;
 }
 
 sub _hashref_to_str {
やっているのは「get」メソッドのパラメータにoptionalな「path」パラメータを足しただけです。このpathパラメータはbase_urlに指定のパスを付け足します。例えば
http://example.com/rest?test=1 とういベースURLに対して $api->get( {
        value => 123,
    }, '/api/foo/bar' );
とすれば http://example.com/rest/api/foo/bar?test=1&value=123 というアクセスになる様な修正です。
ただ、引数の一番最後で良いのかどうかで悩んでcommitはしていません。

今日はこの改造後のWebService::Simpleを使ってLingrに発言するスクリプトを作ってみました。(こんなにスマートになるよ!という意味で)
このサンプルは上記codereposにある物のコピーです。
use strict;
use warnings;
use WebService::Simple;

my $api_key  = "your_api_key";
my $room_id  = "hO4SmQWTdJ4"; # http://www.lingr.com/room/hO4SmQWTdJ4
my $nickname = "lingr.pl";
my $message  = $ARGV[0] || "Hello, World.";

my $lingr = WebService::Simple->new(
    base_url => 'http://www.lingr.com/',
    param    => { api_key => $api_key, format => 'xml' }
);

# create session, get session
my $response;
$response = $lingr->get( {}, { path => '/api/session/create' } );
my $session = $response->parse_xml->{session};

# enter the room, get ticket
$response = $lingr->get(
    {
        session  => $session,
        id       => $room_id,
        nickname => $nickname,
    },
    { path => '/api/room/enter' }
);
my $ticket = $response->parse_xml->{ticket};

# say 'Hello, World'
$response = $lingr->get(
    {
        session => $session,
        ticket  => $ticket,
        message => $message,
    },
    { path => '/api/room/say' }
);
my $status = $response->parse_xml->{status};

# destroy session
$lingr->get( { session => $session, }, { path => '/api/session/destroy' } );
base_urlが変る事で毎回WebService::Simpleを作らなくても良くなり、スッキリした感じです。
ゆーすけべーさんには、案だけ採用して貰いたい。(私の下手なコードは使わないで下さいという意味)
Posted at by



2008/04/01


以前、miyagawa氏作のXML::Atom::ServerをベースとしてXSをなるべく使わない「XML::Atom::Server::Lite」というのを作ってCodeReposに放置していたのですが、そろそろ放置しすぎな感もあったので発作的にエントリ。
「XML::Atom::Server::Lite」は「XML::Atom::Server」と構造をほぼ同じにしてあり、中で使用しているXML::Atomを自前のXSを使わないクラスで置き換えてしまおうというモジュールです。
LibXMLが使えないサーバには、もしかしたら有用かもしれません。サーバ用途だけならばLWPも使いませんし、簡単に低コストでAtom::Serverが実現出来ると思います。
「Digest::SHA」も「Digest::SHA::PurePerl」で置き換えています。
今日はこの「XML::Atom::Server::Lite」を使ってblosxomのAtom::Serverを作ってみました。
ソースは以下の通り。
#!/usr/bin/perl

package Blosxom::AtomPP;
use strict;
use base qw( XML::Atom::Server::Lite );
use File::Find;
use File::stat;

if (-e "/path/to/blosxom/config/file/config.cgi") {
    package blosxom;
    require '/path/to/blosxom/config/file/config.cgi';
}

my %Passwords = (
    yourname => 'yourpassword',
);
my $postsWanted = 10;

sub password_for_user {
    my $server = shift;
    my($username) = @_;
    $Passwords{$username};
}

sub getFilenameFromPostId {
  my $postid = shift @_;
  unless ( $postid =~ /$blosxom::datadir/ ) {
    if ( $postid =~ m!^/! ) {
      #Post ID now has a preceeding /
      $postid = $blosxom::datadir . $postid;
    } else {
      $postid = "$blosxom::datadir/$postid";
    }
  }
  return $postid;
}

sub getRandomFilename {
  my $time = time;
  $time .= int( rand(10) );
  $time .= int( rand(10) );
  return $time;
}

sub decode_html {
    my $str = shift @_;
    $str =~ s/&#([0-9]+);/chr($1)/ge;
    $str =~ s/&#[xX]([0-9A-Fa-f]+);/chr(hex $1)/ge;
    $str =~ s!\x0D|\x0A!<br />\n!g;
    $str =~ s/\&gt;/>/g;
    $str =~ s/\&lt;/</g;
    $str =~ s/\&quot;/"/g;
    $str =~ s/\&amp;/\&/g;
    return $str;
}

sub getPost {
    my $filename  = shift @_;
    my $start     = shift @_ || $blosxom::datadir;
    my $extension = shift @_ || $blosxom::file_extension;

    if ( -e $filename ) {
        open POST, "$filename";
        my @post = <POST>;
        close POST;
        my %struct;
        $struct{'postid'}      = $filename;
        $struct{'dateCreated'} = File::stat::stat($filename)->mtime;
        my $title              = shift @post;
        $title                 =~ s!\x0D|\x0A!!g;
        $struct{'title'}       = $title;
        foreach (@post) {
            my $line = $_;
            if ( !$struct{'subject'} && $line =~ /^meta-tags: (.*)$/ ) {
                $line = $1;
                $line =~ s!\x0D|\x0A!!g;
                my @subjects = split(/\s*,\s*/, $line);
                $struct{'subject'} = \@subjects;
            } else {
                $struct{'description'} .= $line;
            }
        }
        my @cats;
        $filename =~ s/$start(\/.*)\/.*$extension$/$1/ or $filename = "/";
        push @cats, $filename;
        $struct{'categories'} = \@cats;
        return \%struct;
    }
    else {
        return 0;
    }
}

sub newPost {
    my $struct    = shift @_;
    my $start     = shift @_ || $blosxom::datadir;
    my $extension = shift @_ || $blosxom::file_extension;

    my $filename;

    if ( defined( $struct->{'postid'} ) ) {
        $filename = getFilenameFromPostId( $struct->{'postid'} );
    }
    else {
        $filename = lc( $struct->{'title'} );
        $filename =~ s/\W+/_/g;
        $filename =~ s/_+$//;
        $filename = getRandomFilename() unless $filename =~ m/[a-z]/;
        if ( $struct->{'categories'} ) {
            $filename =
              "$start/$struct->{'categories'}[0]/$filename.$extension";
        }
        else {
            $filename = "$start/$filename.$extension";
        }
    }

    chomp $struct->{'title'};
    chomp $struct->{'description'};

    unless ( -e $filename ) {
        open POST, ">$filename.old" or die "Can't Open File $filename: $!";
        print POST decode_html($struct->{'title'})."\n";
        print POST decode_html($struct->{'description'})."\n";
        close POST;
        my $files = chmod 0664, $filename;
    }
    return $filename;
}

sub getEntry {
    my $filename = shift;
    my $post = getPost( $filename );
    return unless $post;

    my $entry = XML::Atom::Server::Lite::Entry->new;
    my $extension = $blosxom::file_extension;

    $entry->title($post->{title});

    my $url = $blosxom::url.$post->{'postid'};
    $url =~ s/$extension$/htm/;
    $entry->link({
            type=>'text/html',
            rel=>'alternate',
            href=>$url,
    });

    $entry->content({
            mode=>'xml',
            type=>'xhtml',
            body=>$post->{description},
    });

    for my $cat (@{$post->{categories}}) {
        $entry->category({
                term=>$cat,
                label=>$cat,
        });
    }
    $entry->subject(@{$post->{subject}});
    return $entry;
}

sub handle_request {
    my $server = shift;
    my $method = $server->request_method;
    $server->authenticate or return;
    if ($method eq 'POST') {
        return $server->new_post;
    }
    $server->response_code(200);
    $server->response_content_type('application/x.atom+xml');

    my $start       = $blosxom::datadir;
    my $extension   = $blosxom::file_extension;
    my $url = $server->path_info;
    if ($url =~ /$blosxom::file_extension$/) {
         my $entry = getEntry( "$start/$url.old" );
        return $entry->as_xml;
    } else {
        my %posts;
        File::Find::find(
            sub {
                $File::Find::name =~ /$extension$/
                  ? $posts{$File::Find::name} =
                  File::stat::stat($File::Find::name)->mtime
                  : 0;
            },
            $start
        );
        my @postList = sort { $posts{$b} <=> $posts{$a} } keys %posts;
        if ( $#postList > $postsWanted ) {
            @postList = @postList[ 0 .. ( $postsWanted - 1 ) ];
        }
        my $feed = XML::Atom::Server::Lite::Feed->new;
        $feed->title($blosxom::blog_title);
        $feed->link({
            rel => 'self',
            type => 'application/atom+xml',
            title => $blosxom::blog_title,
            href => $server->uri,
        });
        $feed->link({
            rel => 'alternate',
            type => 'text/html',
            title => $blosxom::blog_title,
            href => $server->uri,
        });
        $feed->link({
            rel => 'service.post',
            type => 'application/x.atom+xml',
            title => $blosxom::blog_title,
            href => $server->uri,
        });
        for my $filename (@postList) {
            my $entry = getEntry( $filename );
            $feed->add_entry( $entry ) if $entry;
        }
        return $feed->as_xml;
    }
}

my %esc = (
    "\a" => "\\a",
    "\b" => "\\b",
    "\t" => "\\t",
    "\n" => "\\n",
    "\f" => "\\f",
    "\r" => "\\r",
    "\e" => "\\e",
);

sub qquote {
  local($_) = shift;
  s/([\\\"\@\$])/\\$1/g;
  my $bytes; { use bytes; $bytes = length }
  s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
  return qq("$_") unless
    /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/;  # fast exit

  my $high = shift || "";
  s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

  if (ord('^')==94)  { # ascii
    # no need for 3 digits in escape for these
    s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
    s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
    # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
    if ($high eq "iso8859") {
      s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
    } elsif ($high eq "utf8") {
#     use utf8;
#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    } elsif ($high eq "8bit") {
        # leave it as it is
    } else {
      s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
      s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    }
  }
  else { # ebcdic
      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
       {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
       {'\\'.sprintf('%03o',ord($1))}eg;
  }

  return qq("$_");
}

sub get_content_node {
    my $tree = shift;
    if ($tree->{children} && (@{$tree->{children}} eq 1)
            && $tree->{children}->[0]->{name} eq 'content') {
        $tree = $tree->{children}->[0];
        for my $item (@{$tree->{children}}) {
            if ($item->{name} eq 'div' && $item->{attributes}
                && $item->{attributes}->{xmlns} =~ 'http://www.w3.org/1999/xhtml') {
                $tree = $item;
                for my $nobr (@{$tree->{children}}) {
                    return $nobr if $nobr->{name} ne 'br' && $nobr->{type} eq 'tag';
                }
                last;
            }
        }
    }
    $tree;
}

sub to_xml {
    my $tree = shift;
    my $xml;
    if ($tree->{name}) {
        $xml .= "<".$tree->{name};
        for my $attr (keys %{$tree->{attributes}}) {
            $xml .= " $attr=".qquote($tree->{attributes}->{$attr});
        }
    } elsif ($tree->{content}) {
        $xml .= $tree->{content};
    }
    if ($tree->{children}) {
        $xml .= ">" if $tree->{name};
        foreach my $item (@{$tree->{children}}) {
            $xml .= to_xml($item);
        }
        $xml .= "</".$tree->{name}.">" if $tree->{name};
    } elsif ($tree->{name}) {
        $xml .= "/>";
    }
    $xml;
}
sub new_post {
    my $server = shift;
    my $entry = $server->atom_body or return;

    my $struct = {};

    my $url = $server->path_info || $entry->link;
    $url =~ s/htm$/$blosxom::file_extension/;
    $struct->{postid} = $url;
    $struct->{title} = $entry->title;
    my $tree_parser = XML::Parser::Lite::Tree::instance();
    my $tree = $tree_parser->parse( $entry->content->body );
    my $data = to_xml(get_content_node($tree));
    $struct->{description} = $data;
    $struct->{categories} = $entry->{category};

    my $filename = newPost( $struct );
    my $created = getEntry( $filename );
    $server->response_code(201);
    $server->response_content_type('application/x.atom+xml');
    $server->response_header(Location => $server->uri.$struct->{postid});
    return $created;
}

package main;
my $server = Blosxom::AtomPP->new;
$server->run;
厳密な「service.post」や「alternate」ではありませんが「XML::Atom::Server::Lite」の検証としてはこの程度で十分かなと思ってます。ポストも出来ます(認証はWSSE)。
Zoundry Ravenというブログツールでは動作を確認しました。
zoundry-raven

おそらくですが
  • 「XML::Atom::Server::Lite」を「XML::Atom::Server」
  • 「XML::Atom::Server::Lite::Feed」を「XML::Atom::Feed」に
  • 「XML::Atom::Server::Lite::Entry」を「XML::Atom::Entry」に
戻せば、そのまま動くかと思います。
なお、「XML::Atom::Server::Lite」はSOAPには対応していません。馬力のある方は適当に弄って下さい。

これでblosxomにXMLRPCとAtomのインタフェースが揃った事になるのかな?
Posted at by



2008/03/26


なんか久々。
/lang/perl/plagger/lib/Plagger/Plugin/Publish/Diigo.pm - CodeRepos::Share - Trac
www.diigo.com...ブックマークレットから実行出来る専用ポスト画面がなかなかカッコイイ。
今回はこのブックマークレットのhackで作った。

これで、私が同期しているソーシャルブックマークは
  • Publish::Delicious
  • Publish::LivedoorClip
  • Publish::Buzzurl
  • Publish::LivedoorCilp
  • Publish::Buzzurl
  • Publish::GooBookmark
  • Publish::NiftyClip
  • Publish::Pookmark
  • Publish::YahooBookmark
  • Publish::FC2Bookmark
  • Publish::BlueDot という名の Pubilsh::Delicious
  • Publish::Magnolia という名の Publish::Delicious
  • Publish::Diigo
となった。
以下、今後変わっていくかもしれないけどコード。

続きを読む...

Posted at by