PerlでAzure(2)

　順調です。
　Authorization の問題がクリアできたら、一気に進む進む。

　今のところ、Azure::Table モジュールで次の機能が出来ました。
・QUERY TABLE
・CREATE
・DELETE

　次から Entity 操作ですね。
　意外と Entity 操作もすぐできちゃうかも。

参考
http://msdn.microsoft.com/en-us/library/dd179423.aspx

　以下に現状の Azure::Table.pm を記述します。
　Perl として綺麗に書けていないから、モジュール化とかをちゃんと考えないと駄目ですね。

package Azure::Table;

use Exporter;
@ISA = qw(Exporter);
#@EXPORT = qw( new create_table list exists );

# 使用するモジュール

use Time::gmtime;
use Encode;
use MIME::Base64;
use Digest::SHA qw(hmac_sha256_base64);
use LWP::UserAgent;
use LWP::Simple;
use XML::Simple;
use Data::Dumper;

our $BLOB	= "blob.core.windows.net";
our $QUEUE	= "queue.core.windows.net";
our $TABLE	= "table.core.windows.net";

our $LAST_STATUS	= 0;
our $LAST_ERROR		= '';

sub new
{
	my $class	= shift;
    my $this	=
	{
		@_
	};

	bless $this, $class;

	$this->{target}		= defined( $this->{target} ) ? $this->{target} : $TABLE;

	return $this;
}

sub create
{
	my $this	= shift;
	my $table	= shift;
	my $version	= shift if @_;

	if ( !defined($table) || length($table) == 0 || $this->exists($table) )
	{
		$LAST_ERROR = "Tablle::create [ error ] : Table $table is already exist.";
		return 1;
	}

	my $path = Azure::Table::create_uri( $this->{'account'}, $TABLE, "/Tables" );
	my $date = &create_utc();
	my $lite = &create_sig_lite( $this->{'account'}, "/Tables", $date );
	my $auth = &create_auth( $this->{'account'}, "SharedKeyLite", $lite, $this->{'authkey'} );

	my $req	= HTTP::Request->new ( POST => $path );
	my $ua	= LWP::UserAgent->new;
	$ua->agent('Perl::Azure::Table/0.1');
	$ua->timeout(5);

	# 認証用の必須ヘッダーを記述
	$ua->default_header("Authorization"	=> $auth );
	$ua->default_header("x-ms-date"		=> $date );
#	if ( defined($version) )
#	{
#		$ua->default_header("x-ms-version"		=> $version );
#	}

	# Request 作成
	$req->content_type( "application/atom+xml" );

	my $update = &create_update();
	my $content =<< "EOC";
<?xml version='1.0' encoding='utf-8' standalone='yes'?>
<entry xmlns:d='http://schemas.microsoft.com/ado/2007/08/dataservices'
	xmlns:m='http://schemas.microsoft.com/ado/2007/08/dataservices/metadata'
	xmlns='http://www.w3.org/2005/Atom'>
	<title />
	<updated>$update</updated>
	<author>
		<name />
	</author>
	<id />
	<content type='application/xml'>
		<m:properties>
			<d:TableName>$table</d:TableName>
		</m:properties>
	</content>
</entry>
EOC

	$req->content($content);
	print "$content";

	# リクエスト送信
	my $res = $ua->request($req);

	my @tables;
	if ( $res->is_success && $res->code == 201 )
	{
		print $res->content;
	}
	else
	{
		$LAST_STATUS = $res->code;
		print $res->content;
		return 1;
	}

	return 0;
}

sub list
{
	my $this = shift;

	my $path = Azure::Table::create_uri( $this->{'account'}, $TABLE, "/Tables" );
	my $date = &create_utc();
	my $lite = &create_sig_lite( $this->{'account'}, "/Tables", $date );
	my $auth = &create_auth( $this->{'account'}, "SharedKeyLite", $lite, $this->{'authkey'} );

	my $req	= HTTP::Request->new ( GET => $path );
	my $ua	= LWP::UserAgent->new;
	$ua->agent('Perl::Azure::Table/0.1');
	$ua->timeout(5);

	# 認証用の必須ヘッダーを記述
	$ua->default_header("x-ms-date"		=> $date );
	$ua->default_header("Authorization"	=> $auth );
#	if ( defined($version) )
#	{
#		$ua->default_header("x-ms-version"		=> $version );
#	}

	# リクエスト送信
	my $res = $ua->request($req);

	my @tables;
	if ( $res->is_success )
	{
		$_ = $res->content;
		push( @tables, /<d\:TableName>(.+)<\/d\:TableName>/g );
	}
	else
	{
		$LAST_STATUS = $res->code;
	}
	return @tables;
}

sub exists
{
	my $this	= shift;
	my $table	= shift;

	@tables = $this->list();
	foreach ( @tables )
	{
		return 1 if $_ eq $table ;
	}
	return 0;
}

sub delete
{
	my $this	= shift;
	my $table	= shift;

	if ( ! $this->exists($table) )
	{
		print "No such table $table in Tables.\n";
		return 0;
	}

	my $path = Azure::Table::create_uri( $this->{'account'}, $TABLE, "/Tables('$table')" );
	my $date = &create_utc();
	my $lite = &create_sig_lite( $this->{'account'}, "/Tables('$table')", $date );
	my $auth = &create_auth( $this->{'account'}, "SharedKeyLite", $lite, $this->{'authkey'} );

	my $req	= HTTP::Request->new ( DELETE => $path );
	my $ua	= LWP::UserAgent->new;
	$ua->agent('Perl::Azure::Table/0.1');
	$ua->timeout(5);

	# 認証用の必須ヘッダーを記述
	$ua->default_header( "x-ms-date"		=> $date );
	$ua->default_header( "Authorization"	=> $auth );

	# Request 作成
	$req->content_type( "application/atom+xml" );

	# リクエスト送信
	my $res = $ua->request($req);

	print $res->content;

	my @tables;
	if ( $res->is_success )
	{
		print "Succeeded to delete table $table.\n";
	}
	else
	{
		$LAST_STATUS = $res->code;
		return 1;
	}

	return 0;
}


# URI 作成
sub create_uri
{
	my $account	= shift;
	my $target	= shift;
	my $path	= shift;

    return sprintf("https://%s.%s%s", $account, $target, $path);
}

# GMT 時間取得
sub create_utc
{
	my $gm    = gmtime();
	my $week  = (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $gm->wday() ];
	my $month = (qw(Jan Feb Mar Apl May Jun Jul Aug Sep Oct Nov Dec))[ $gm->mon() ];
	my $year  = ( $gm->year() < 1900 ) ? $gm->year() + 1900 : $gm->year();
	my $date  = sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", $week, $gm->mday(), $month, $year,
		$gm->hour(), $gm->min(), $gm->sec() );

	return $date;
}

# Atom Update 用時間取得
sub create_update
{
	my $gm    = gmtime();
	my $week  = (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $gm->wday() ];
	my $month = (qw(Jan Feb Mar Apl May Jun Jul Aug Sep Oct Nov Dec))[ $gm->mon() ];
	my $year  = ( $gm->year() < 1900 ) ? $gm->year() + 1900 : $gm->year();
	my $date  = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ", $year, $gm->mon() + 1, $gm->mday(),
		$gm->hour(), $gm->min(), $gm->sec() );

	return $date;
}

# SharedLiteKey のシグネイチャー作成
sub create_sig_lite
{
	my $account	= shift;
    my $path    = shift;
    my $date    = shift;

    return sprintf("%s\n/%s%s", $date, $account, $path);
}

# 認証コード作成
sub create_auth
{
	my $account = shift;
    my $type    = shift;
    my $sign    = shift;
    my $key     = shift;

	$key = decode_base64($key);

    my $octets  = encode('utf8', $sign);
    my $code    = hmac_sha256_base64($octets, $key);
    $code      .= '=' while length($code) % 4;

    return sprintf("%s %s:%s", $type, $account, $code);
}

1;
__END__

　サンプルコードで自前の Azure Table にアクセスすると、こんな感じで結果が返ります。

D:\Develop\Azure\Perl>get_req.pl
ArticleEntity SampleEntity
Table ArticleEntity exists.
Failed to create SampleEntity table.
Status code : 0
Succeeded to delete table SampleEntity.
Succeed to delete SampleEntity table.