Big Sky

Freenodeのwebchatインタフェースを叩いて通信し、携帯電話からでもIRC出来るCGI書いた。
欲しい人なんかいるんかなーとか思いながら、作ったのでメッセージの送受信しか出来ません。 nick登録もなし、nickの自動割り当てもなしです。
私はこんだけあったら十分なので...。コードはこの辺にあります。

mattn's freenode-mobile-gateway at master - GitHub

IRC gateway for freenode writen in perl.

http://github.com/mattn/freenode-mobile-gateway/tree/master

SoftBank携帯ですが、一応動いてます。欲しい機能があればgithubでforkして下さい。

VCだとビルド出来るらしいけど、strawberry perlとかだとコンパイル出来ない。
まずCoro側のpatch。

diff -ur Coro-5.132.orig/Coro/libcoro/coro.c Coro-5.132/Coro/libcoro/coro.c
--- Coro-5.132.orig/Coro/libcoro/coro.c 2008-11-19 11:50:13.000000000 +0900
+++ Coro-5.132/Coro/libcoro/coro.c  2009-06-19 15:01:16.140625000 +0900
@@ -228,6 +228,9 @@
   #if __CYGWIN__
     ctx->env[7] = (long)((char *)sptr + ssize) - sizeof (long);
     ctx->env[8] = (long)coro_init;
+  #elif defined(__MINGW32__)
+    ctx->env[4] = (int)((unsigned char *)sptr + ssize);
+    ctx->env[5] = (long)coro_init;
   #elif defined(_M_IX86)
     ((_JUMP_BUFFER *)&ctx->env)->Eip   = (long)coro_init;
     ((_JUMP_BUFFER *)&ctx->env)->Esp   = (long)STACK_ADJUST_PTR (sptr, ssize) - sizeof (long);

mingw32のjumpbufは4番目がEipで5番目がEspだったはず。
一応手元で動いてます。
あとこのままでも駄目で、ExtUtils::MakeMakerがgccの時に付けてしまう--image-baseオプションがまずい。
アドレスの作り方が Coro::Event であれば Event という文字列に対して上位4バイト、下位4バイトで分けてunpackとかやってござる。

    if ($GCC) {
        my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
        $dllname =~ /(....)(.{0,4})/;
        my $baseaddr = unpack("n", $1 ^ $2);
        $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
    }

なので、Coro::Event が使っている Event というモジュールと --image-base がバッティングして起動時にメモリロケーション不正参照のエラーが起きる。
こちらについては、ExtUtils::MakeMakerに含まれる MM_Win32.pm を修正する。最近の gcc は勝手に --image-base 作ってくれるので、そちらに任せる。

--- MM_Win32.pm.orig    2009-06-22 17:48:43.906250000 +0900
+++ MM_Win32.pm 2009-06-22 17:49:05.703125000 +0900
@@ -307,12 +307,12 @@
 # we try to overcome non-relocateable-DLL problems by generating
 #    a (hopefully unique) image-base from the dll's name
 # -- BKS, 10-19-1999
-    if ($GCC) {
-       my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
-       $dllname =~ /(....)(.{0,4})/;
-       my $baseaddr = unpack("n", $1 ^ $2);
-       $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
-    }
+#    if ($GCC) {
+#      my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
+#      $dllname =~ /(....)(.{0,4})/;
+#      my $baseaddr = unpack("n", $1 ^ $2);
+#      $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
+#    }
 
     push(@m,'
 # This section creates the dynamically loadable $(INST_DYNAMIC)

SYNOPSISの例でもちゃんと動きます。

あとはバグ報告から上手く修正されれば...

SQLite便利！

SQLite3におけるREGEXP演算子 - anon_193の日記

SQLite では、load_extension 関数を用いて、外部の拡張モジュールをロードすることが出来る。拡張モジュールは、いわばユーザ関数ライブラリで、SQLite3 ODBC Driver には標準で BLOB二次元マッピング拡張(sqlite3_mod_blobtoxy.dll)、外部データ取込・出力拡張(sqlite3_mod_impexp.dll)、全文検索拡張(sqlite3_mod_fts3.dll) が付属している。これらと同様にして、正規表現マッチングを行う regexp ユーザ関数を持つ拡張モジュールを制作し、ロードすれば、お目当ての REGEXP 演算子が使えるわけだ。

http://d.hatena.ne.jp/anon_193/20090114/1231935112

sqlite3_mod_regexp.cxx

#include <boost/regex.hpp>
#include <sqlite3ext.h>
extern "C" {
    SQLITE_EXTENSION_INIT1
    static void regexp_func(sqlite3_context *context, int argc, sqlite3_value **argv) {
        if (argc >= 2) {
            const char *target  = (const char *)sqlite3_value_text(argv[1]);
            const char *pattern = (const char *)sqlite3_value_text(argv[0]);
            try {
                boost::regex ereg(pattern, boost::regex_constants::perl);
                sqlite3_result_int(context, boost::regex_search(target, ereg));
            } catch (boost::regex_error &e) {
                sqlite3_result_error(context, e.what(), 0);
            }
        }
    }
    __declspec(dllexport) int sqlite3_extension_init(sqlite3 *db, char **errmsg, const sqlite3_api_routines *api) {
        SQLITE_EXTENSION_INIT2(api);
        return sqlite3_create_function(db, "regexp", 2, SQLITE_UTF8, (void*)db, regexp_func, NULL, NULL);
    }
}

VCでコンパイルしました。

# cl /EHsc -Isrc -I. -I "c:\boost_1_35_0" sqlite3_mod_regexp.cxx /LD "C:\boost_1_35_0\libs\regex\build\vc80\libboost_regex-vc80-mt-s-1_35.lib"

サンプルデータ
foo.sql

CREATE TABLE foo(id integer primary key, value text);
INSERT INTO "foo" VALUES(1,'abc');
INSERT INTO "foo" VALUES(2,'def');
INSERT INTO "foo" VALUES(3,'あいうえお');
INSERT INTO "foo" VALUES(4,'かきくけこ');
INSERT INTO "foo" VALUES(5,'さしすせそ');

utf-8で保存して下さい

# cat foo.sql | sqlite3 foo.db

そしてPerlのコード

use strict;
use warnings;
use utf8;
use YAML;
use DBIx::Simple;

my $db = DBIx::Simple->connect("dbi:SQLite:dbname=c:/foo.db", "", "")
    or die DBIx::Simple->error;

$db->func(1, "enable_load_extension");

my $result = $db->query("select load_extension('/sqlite3_mod_regexp.dll')")
    or die DBIx::Simple->error;
warn Dump $db->query("select * from foo where value regexp '^[あか]'")->hashes;

dbのパスとdllのパスは指定して下さい
実行すると...

---
id: 3
value: あいうえお
---
id: 4
value: かきくけこ

スゲーーーー便利！

書いた。

use strict;
use warnings;
use lib qw/lib/;
use GNTP::Growl;

my $growl = GNTP::Growl->new(AppName => "my perl app");
$growl->register([
    { Name => "foo", },
    { Name => "bar", },
]);

$growl->notify(
    Event => "foo",
    Title => "おうっふー おうっふー",
    Message => "大事な事なので\n2回言いました",
    Icon => "http://mattn.kaoriya.net/images/logo.png",
);

こんなソースで

こんな物が動く。
開発はこの辺で...

mattn's perl-gntp-growl at master - GitHub

twitterのOAuthベータが開始されたので、さっそく軽量Web Application Framework「MENTA」でOAuthする物を作ってみた。
構成も簡単で

│  .htaccess
│  menta.cgi
├─app
│  ├─controller
│  │      callback.pl
│  │      request.pl
│  ├─data
│  └─static
├─bin
├─lib
└─plugins
        session.pl

こんな感じ。トップページからrequest.plに飛び、OAuthのcallbackとしてcallback.plがキックされる。
要のrequest.plは以下の様な感じ

use MENTA::Controller;
use URI;
use OAuth::Lite::Consumer;

sub run {
    my $consumer = OAuth::Lite::Consumer->new(
        consumer_key       => config()->{application}->{consumer_key},
        consumer_secret    => config()->{application}->{consumer_secret},
        site               => 'http://twitter.com/',
        request_token_path => 'http://twitter.com/oauth/request_token',
        access_token_path  => 'http://twitter.com/oauth/access_token',
        authorize_path     => 'http://twitter.com/oauth/authorize',
    );

    my $request_token = $consumer->get_request_token();
    my $uri           = URI->new( $consumer->{authorize_path} );
    $uri->query(
        $consumer->gen_auth_query(
            "GET", "http://twitter.com/", $request_token
        )
    );
    redirect( $uri->as_string );
}

そしてcallback.plはこんな感じ

use utf8;
use MENTA::Controller;
use OAuth::Lite::Consumer;
use JSON;

sub run {
    my $consumer = OAuth::Lite::Consumer->new(
        consumer_key       => config()->{application}->{consumer_key},
        consumer_secret    => config()->{application}->{consumer_secret},
        site               => 'http://twitter.com/',
        request_token_path => 'http://twitter.com/oauth/request_token',
        access_token_path  => 'http://twitter.com/oauth/access_token',
        authorize_path     => 'http://twitter.com/oauth/authorize',
    );

    my $access_token = $consumer->get_access_token( token => param('oauth_token') );
    my $res = $consumer->request(
        method => 'POST',
        url    => q{http://twitter.com/statuses/update.json},
        token  => $access_token,
        params =>
          { status => 'おうっふー', token => $access_token },
    );
    if ( $res->is_success ) {
        my $status = from_json( $res->content );
        redirect( "http://twitter.com/"
              . $status->{user}->{screen_name}
              . "/status/"
              . $status->{id} );
    }
    else {
        redirect("http://twitter.com/");
    }
}

ちなみにこのアプリケーションを"Accept"にするとtwitteのステータスラインに「おうっふー」がポストされます。自分で作る方はtwitterのアプリケーション登録画面から得られるconsumer_keyとconsumer_secretをmenta.cgiのapplication項目に設定するのをお忘れなく。
簡単ですね！