end0tknr's kipple - web写経開発

太宰府天満宮の狛犬って、妙にカワイイ

Email::Stuffer for perlによるメール送信でReturn-Pathをセット

http://end0tknr.hateblo.jp/entry/20150819/1439950536 http://end0tknr.hateblo.jp/entry/20170205/1486293131

Email::Stuffer シリーズ?の第3弾?

メールソフト(MUA)に表示されるアドレスとは、別のアドレスにエラーメールを返送したい為、メモ。 まぁ、ググれば、分かるんですけどね

envelope from と header from の違い?

fromのtype 説明(例)
envelope from 封筒に書かれる差出人. 宛先不明時はこちらへ返送
header from 便箋に書かれる差出人

envelope from と Return-Pathの関係

宛先不明メールは、Return-Path宛に返送されます。 しかし、メールヘッダのReturn-Pathはメールサーバ経由時に書換えられる為、 単純にメールヘッダにReturn-Pathを設定しても意味がありません。

envelope fromこそが、メールサーガ経由時にReturn-Pathに設定される為、 envelope fromにエラーメールの返送先を設定する必要があります。

Email::Stuffer for perlによるメール送信でReturn-Pathをセット

するには、次のように書きます。

ただし、試した範囲では、smtp.gmail.com での送信では、 好みのReturn-Path(envelop from)は設定できませんでした。

#!/usr/local/bin/perl
use strict;
use warnings;
use utf8;
use Email::Stuffer;
use Email::Sender::Transport::SMTP;
use Email::Sender::Transport::SMTP::TLS;
use Data::Dumper;

my $FROM =     'ないしょ@ないしょ.com'; ## HEADER  FROM
my $REPLY_TO = 'ひみつ@ないしょ.com';   ## ENVELOP FROM
my $SUBJECT = 'TEST MAIL';
# auth smtpの場合
my $SMTP_CONF = {host => 'xxx.yyy.zzz.co.jp',
                 port => 587,
                 sasl_username => 'ないしょ',
                 sasl_password => 'ないしょ',
                 debug=>1};
# 素の場合
# my $SMTP_CONF = {host => 'ないしょ.co.jp', port => 25};
# auth smtp(tls)の場合
my $SMTP_TLS_CONF = {host => 'smtp.gmail.com',
                     port => 587,
                     username=>'ないしょ@gmail.com',
                     password=>'ないしょ', # APPのパスワード
                     debug=>1 };


main( @ARGV);

sub main {
    my ($mailto) = @_;
    
    my $email = Email::Stuffer->new();

    my $smtp = get_smtp_obj();
#    my $smtp = get_smtp_obj_tls();
    $email->transport( $smtp );

    $email->subject($SUBJECT);
    $email->from($FROM);            ## HEADER FROM
    $email->to($mailto);
    $email->header('Reply-To' => $REPLY_TO);

    my $txt_mime =  get_txt_mime();  ## 代替text part
    my $html_mime = get_html_mime(); ## html part

    push(@{$email->{parts}}, $txt_mime);
    push(@{$email->{parts}}, $html_mime);

    $email->send_or_die({from=>$REPLY_TO});  ## ENVELOP FROM
}

sub get_smtp_obj_tls {
    my $smtp = Email::Sender::Transport::SMTP::TLS->new($SMTP_TLS_CONF);
    return $smtp;
}

sub get_smtp_obj {
    my $smtp = Email::Sender::Transport::SMTP->new($SMTP_CONF);
    return $smtp;
}

sub get_txt_mime {

    my $attr = {content_type => 'text/plain',
                charset      => 'utf-8',
                encoding     => 'quoted-printable',
                format       => 'flowed'};
    my $body =<<EOF;
これは、テキストメールのテストです。
EOF

    my $mime = Email::MIME->create(attributes => $attr,
                                   body_str   => $body);
    return $mime;
}

sub get_html_mime {
    my $attr = {content_type => 'text/html',
                charset      => 'utf-8',
                encoding     => 'quoted-printable'};
    my $body =<<EOF;
<html>
<head></head>
<body>
これは、<b>HTML</b>メールのテストです。
</body>
</html>
EOF
    my $mime = Email::MIME->create(attributes => $attr,
                                   body_str   => $body);
    return $mime;
}

1;

Email::Stuffer for perl による HTMLメール送信 (HTML+TXTマルチパート)

Email::Stuffer や Email::Sender::Transport::SMTP 、 Email::Sender::Transport::SMTP::TLS に殆どおまかせなので、 以下のように書くだけでOK。

#!/usr/local/bin/perl
use strict;
use warnings;
use utf8;
use Email::Stuffer;
use Email::Sender::Transport::SMTP;
use Email::Sender::Transport::SMTP::TLS;
use Data::Dumper;

my $FROM = 'ないしょ@gmail.com';
my $SUBJECT = 'TEST MAIL';
# auth smtpの場合
my $SMTP_CONF = {host => 'ないしょ.co.jp',
                 port => 587,
                 sasl_username => 'ないしょ',
                 sasl_password => 'ないしょ',
                 debug=>1
                };
# 素の場合
# my $SMTP_CONF = {host => 'ないしょ.co.jp',
#                  port => 25};
# auth smtp(tls)の場合
my $SMTP_TLS_CONF = {host => 'smtp.gmail.com',
                     port => 587,
                     username=>'ないしょ',
                     password=>'ないしょ', # APPのパスワード
                     debug=>1
                    };


main( @ARGV);

sub main {
    my ($mailto) = @_;
    
    my $email = Email::Stuffer->new();

#    my $smtp = get_smtp_obj();
    my $smtp = get_smtp_obj_tls();
    $email->transport( $smtp );

    $email->subject($SUBJECT);
    $email->from($FROM);
    $email->to($mailto);

    my $txt_mime =  get_txt_mime();  ## 代替text part
    my $html_mime = get_html_mime(); ## html part

    push(@{$email->{parts}}, $txt_mime);
    push(@{$email->{parts}}, $html_mime);

    
    $email->send_or_die;
}

sub get_smtp_obj_tls {
    my $smtp = Email::Sender::Transport::SMTP::TLS->new($SMTP_TLS_CONF);
    return $smtp;
}

sub get_smtp_obj {
    my $smtp = Email::Sender::Transport::SMTP->new($SMTP_CONF);
    return $smtp;
}


sub get_txt_mime {

    my $attr = {content_type => 'text/plain',
                charset      => 'utf-8',
                encoding     => 'quoted-printable',
                format       => 'flowed'};
    my $body =<<EOF;
これは、テキストメールのテストです。
EOF

    my $mime = Email::MIME->create(attributes => $attr,
                                   body_str   => $body);
    return $mime;
}

sub get_html_mime {

    my $attr = {content_type => 'text/html',
                charset      => 'utf-8',
                encoding     => 'quoted-printable'};
    my $body =<<EOF;
<html>
<head></head>
<body>
これは、<b>HTML</b>メールのテストです。
</body>
</html>
EOF

    my $mime = Email::MIME->create(attributes => $attr,
                                   body_str   => $body);
    return $mime;
}

1;

perlのCLIでコマンドライン引数を受取りは、Getopt::Long::GetOptions()

↓こんな感じで使用します。とうより、自分用メモ。

#!/usr/local/bin/perl
use strict;
use warnings;
# http://tagomoris.hatenablog.com/entry/20120918/1347991165
use Getopt::Long qw(:config posix_default no_ignore_case gnu_compat);
use Data::Dumper;

my $cmd_opts = {};

main();

sub main {

    my $cmd_opts = {}; # Getopt::Long::GetOptions により引き数が蓄積
    
    my @defined_opts =
        ('conf_file=s','mail_type=s','mail_data=s','subject=s','output=s');
    #不明なoptionが与えられた場合
    unless(Getopt::Long::GetOptions($cmd_opts,@defined_opts)){
        print_usage();
        return;
    }

    #本来?は、ここで、与えられた引き数をvalidataion
    if(scalar(keys %$cmd_opts)==0){
        print_usage();
        return;
    }

    
    #で、その後の処理に入る...
}

sub print_usage {

    print "Usage: $0 COMMAND [OPTION]\n";
    print '  --conf_file=$FILE_PATH',"\n";
    print "  --mail_data=[NULL, BULK_MAIL]\n";
    print '  --subject=$SUBJECT',"\n";
    print '  --output=[NULL, FILE, $MAILTO]',"\n";

}

sleep() , select() , Time::HiRes::sleep() による perlのsleep処理

perlのsleepでは、1秒単位のsleepは組込み関数のsleep()、 1秒未満単位のsleepは Time::HiResの sleep() を使用しますが、 select(undef, undef, undef, $sleep_time)でも、Time::HiRes::sleep() と同様の動作をできるらしい。

#!/usr/local/bin/perl
use strict;
use warnings;
use Time::HiRes;


main();

sub main {

    for my $interval (1.5 , 1.0, 0.5){
        my $start_time = Time::HiRes::time();
        # http://perldoc.perl.org/functions/sleep.html
        sleep($interval);
        my $end_time = Time::HiRes::time();
        my $slept_time = $end_time - $start_time;

        print "sleep( $interval )->slept time $slept_time sec\n";
    }
    print "\n";

    for my $interval (1.5 , 1.0, 0.5){
        ## http://perldoc.perl.org/functions/select.html
        ## http://perldoc.jp/func/select
        my $start_time = Time::HiRes::time();
        select(undef, undef, undef, $interval); ## = sleep

        my $end_time = Time::HiRes::time();
        my $slept_time = $end_time - $start_time;

        print
            "select(undef,undef,undef,$interval)->slept time $slept_time sec\n";
    }
    print "\n";

    for my $interval (1.5 , 1.0, 0.5){
        my $start_time = Time::HiRes::time();
        ## http://search.cpan.org/perldoc?Time%3A%3AHiRes
        Time::HiRes::sleep($interval);
        my $end_time = Time::HiRes::time();
        my $slept_time = $end_time - $start_time;

        print
            "Time::HiRes::sleep($interval)->slept time $slept_time sec\n";
    }
}

つまり↑こう書くと、↓こう表示されます

$ ./foo.pl 
sleep( 1.5 )->slept time 1.00030517578125 sec
sleep( 1 )->slept time 1.00028395652771 sec
sleep( 0.5 )->slept time 9.05990600585938e-06 sec

select(undef,undef,undef,1.5)->slept time 1.50168013572693 sec
select(undef,undef,undef,1)->slept time 1.00239300727844 sec
select(undef,undef,undef,0.5)->slept time 0.500741958618164 sec

Time::HiRes::sleep(1.5)->slept time 1.50391101837158 sec
Time::HiRes::sleep(1)->slept time 1.00040507316589 sec
Time::HiRes::sleep(0.5)->slept time 0.500246047973633 sec

が、perl best practice (PBP)では、お作法違反

らしく、↓このように怒られます

$ perlcritic foo.pl 
"select" used to emulate "sleep" at line 26, column 9.  See page 168 of PBP.  (Severity: 5)

64bit整数等の巨大な数の乱数発生は、Math::BigInt::Random for perl

http://search.cpan.org/perldoc?Math%3A%3ABigInt%3A%3ARandom ↓こうかな?

#!/usr/local/bin/perl
use strict;
use Math::BigInt;
use Math::BigInt::Random;
use Data::Dumper;

main();

sub main {
    my $max = 18_446_744_073_709_551_615;

    my $i = 0;
    while( $i++ < 10 ){
        print Math::BigInt::Random::random_bigint( max => $max ),"\n";
    }
}
$ ./test.pl 
9506841540604143609
17290575413746988769
12642088427333715816
3437943406824129695
4510757347866451250
4637770013828130871
6569924293883749620
11166561186182411725
3618737948898655722
4641358188649576606

MIME::QuotedPrint for perl による Quoted-Printable エンコーディング

http://search.cpan.org/perldoc?Email%3A%3AStuffer

http://search.cpan.org/perldoc?Email%3A%3AMIME

Email::Stuffer & Email::MIME を読んでたら、Email::MIME では、encoding に base64 or quoted-printable or 8bit を指定できるらしい。

quoted-printable (いわゆる QP encoding)は利用したことがなかったので、お試し。

quoted-printable encodingとは?

BASE64との違い等と合せて、ググった方が理解しやすいと思いますので、 ここでは記載しません。

MIME::QuotedPrint

perlで QP encoding するには、MIME::QuotedPrint を利用するよう。 しかも、標準module

http://perldoc.perl.org/MIME/QuotedPrint.html

$ corelist MIME::QuotedPrint
Data for 2014-10-01
MIME::QuotedPrint was first released with perl v5.7.3

$ corelist MIME::Base64;
Data for 2014-10-01
MIME::Base64 was first released with perl v5.7.3

MIME::QuotedPrint のお試し

#!/usr/local/bin/perl
use strict;
use warnings;
use utf8;
use Encode;
use MIME::QuotedPrint;

main();

sub main {
    for my $char_org ('1','A','+','=','あ','あA','あい','α','㈱'){
        my $char_org_utf8 = Encode::encode('utf8',$char_org);

        my $encoded = MIME::QuotedPrint::encode_qp( $char_org_utf8 );
        my $decoded = MIME::QuotedPrint::decode_qp($encoded);

        print join(" -> ", $char_org_utf8, $encoded, $decoded),"\n\n";
    }
}

↑こう書くと、↓こう表示されます。

$ ./test.pl 
1 -> 1=
 -> 1

A -> A=
 -> A

+ -> +=
 -> +

= -> =3D=
 -> =

あ -> =E3=81=82=
 -> あ

あA -> =E3=81=82A=
 -> あA

あい -> =E3=81=82=E3=81=84=
 -> あい

α -> =CE=B1=
 -> α

㈱ -> =E3=88=B1=
 -> ㈱

「encode_qp()」された文字列の最後には、改行文字が追加されるみたい。

client (javascript)側で、ログ出力し、それをサーバへ送信

qiita.com

上記を参考に、以下のように書いてみた。

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
</head>
<body>
  <button type="button"
      onClick="log.error('LOG1','LOG2' );">TEST ERROR</button>
  <button type="button"
      onClick="log.warn('LOG1','LOG2' );">TEST WARN</button>
  <button type="button"
      onClick="log.info('LOG1','LOG2' );">TEST INFO</button>
  <button type="button"
      onClick="log.debug('LOG1','LOG2' );">TEST DEBUG</button>
</body>
<script type="text/javascript" src="js/jquery.js"></script>
<script type="text/javascript" src="js/Logger.js"></script>
<script>
 $(document).ready(function(){
//   log.set_level('none'); //必要であれば、出力ログレベルを設定
 });
</script>
</html>
(function() {
    var Logger = function(){
        this.level = this.LEVEL['info']; // set default disp level
    };
    
    Logger.prototype = {
        LEVEL : {none:0, error:1, warn:2, info:3, debug:4 },
        SERVER_LOG_URL : '/client_log.png', //設定値があれば、サーバへログ送信

        set_level: function(lavel){
            this.level = this.LEVEL[lavel];
        },
        error : function(){
            this._log(arguments.callee.name,this._args2array(arguments));
        },
        warn : function(){
            this._log(arguments.callee.name,this._args2array(arguments));
        },
        info : function(){
            this._log(arguments.callee.name,this._args2array(arguments));
        },
        debug : function(){
            this._log(arguments.callee.name,this._args2array(arguments));
        },

        _is_disp: function( level ){ //console objや、log levelの確認
            if(window.console &&
               typeof window.console[level] === 'function' &&
               this.level >= this.LEVEL[level] ){
                return true;
            }
            return false;
        },
        _log: function(func_name, msgs){
            if(! this._is_disp(func_name)) return;
            console[func_name]( msgs.join(' '));

            if(this.SERVER_LOG_URL ){
                this._log_to_server(func_name, msgs);
                return;
            }
        },
        _log_to_server: function(func_name, msgs){ //サーバへログ送信
            var msgs_str = func_name +'='+ msgs.join('_');
            var now  = (new Date()).getTime() + Math.random() * 1000 ;
            var url =
                this.SERVER_LOG_URL +'?'+ encodeURI(msgs_str) +"&time="+now;
            var dummy_img = new Image();
            dummy_img.src = url;
        },
        
        _args2array : function(arguments){ //可変長引数対応の為、Array型に変換
            var ret = [];
            for (var i = 0; i < arguments.length; i++) {
                ret.push(arguments[i]);
            }
            return ret;
        }
        
    };
    window.log = new Logger();
})();

eclipseのプラグイン一覧をequinoxコンソールで確認

普通?にeclipseを起動し、メニューバー -> Help -> Installation Details で表示されるダイアログでも確認できますが、 windowsコマンドプロンプトを起動し、equinoxコンソールでも次のように確認できます。

C:\>cd \eclipse
C:\eclipse> eclipsec.exe -console
  :
osgi>ss  
"Framework is launched."
id      State       Bundle
0       ACTIVE      org.eclipse.osgi_3.10.2.v20150203-1939
                    Fragments=1
1       RESOLVED    org.eclipse.osgi.compatibility.state_1.0.1.v20140709-1414
                    Master=0
2       ACTIVE      org.eclipse.equinox.simpleconfigurator_1.1.0.v20131217-1203
3       RESOLVED    ch.qos.logback.classic_1.0.7.v20121108-1250
                    Fragments=533
4       RESOLVED    ch.qos.logback.core_1.0.7.v20121108-1250
5       RESOLVED    ch.qos.logback.slf4j_1.0.7.v20121108-1250
                    Master=836
6       RESOLVED    com.google.guava_15.0.0.v201403281430
:          :               :

「bundle $no」と実行することで、指定したbundleの詳しい情報を表示できます(以下)

osgi> bundle 1
org.eclipse.osgi.compatibility.state_1.0.1.v20140709-1414 [1]
  Id=1, Status=RESOLVED    Data Root=C:\eclipse\configuration\org.eclipse.osgi\1\data
  "No registered services."
  No services in use.
  No exported packages
  No imported packages
  Host bundles
    org.eclipse.osgi_3.10.2.v20150203-1939 [0]

主に利用するコマンドは以下で、その他はhelpをご覧下さい

osgi> start   $bundle_id
osgi> stop    $bundle_id
osgi> update  $bundle_id
osgi> refresh $bundle_id

osgi> help

今回は以下を参考にしましたが、OSGIではIFと実装を別バンドルにするといいらしい。

tech-ragtime.seesaa.net

perlからc/c++ の関数利用は FFI::Platypus >> perlxs

FFI::Platypus - search.cpan.org

どうやら最近は、FFI::Platypus なるmoduleが存在し、 xs よりも簡単に c/c++ の関数を利用できるみたい。

SYNOPSIS のサンプルコードやdocumentを参照する限り、簡単そ

ssh port fowarding (ssh tunnel)で、remoteのmysql(RDS)に接続

忘れていたので、メモ

$ ssh -L 5000:xxxx-db.hogehoge.ap-northeast-1.rds.amazonaws.com:3306 \
      -i ~/.ssh/id_rsa \
      end0tknr@12.34.56.78

とやっておいて、別窓で、↓こう

$ /usr/local/mysql/bin/mysql --port=5000 -u foouser -p hogedb

rsync failed: command exited with code 12: error in rsync protocol data stream

rsync failed: command exited with code 12: error in rsync protocol data stream

と、エラーになったので、調べてたら、local と remote のファイルのオーナーが異なっていたので、chown した。

おはずかしい

Date::Calc for perl で、GMT <-> Localtime 変換

こんな感じかな?

#!/usr/local/bin/perl
use strict;
use warnings;
use utf8;
use Date::Calc;
use Data::Dumper;

main(@ARGV);

# http://search.cpan.org/perldoc?Date%3A%3ACalc

sub main {

    gmt_to_local();
    local_to_gmt();
}

sub gmt_to_local {

    my $is_gmt = 1;
    my @now = Date::Calc::Today_and_Now($is_gmt);
    my @tzone = Date::Calc::Timezone();
    my @now_2 = Date::Calc::Add_Delta_YMDHMS(@now[0..5], @tzone[0..5]);

    print "GMT->LOCAL : ";
    print sprintf("%04d-%02d-%02d %02d:%02d:%02d",@now);
    print " -> ";
    print sprintf("%04d-%02d-%02d %02d:%02d:%02d",@now_2),"\n\n";
}

sub local_to_gmt {

    my @now = Date::Calc::Today_and_Now();
    my @tzone = Date::Calc::Timezone();
    my @now_2 = Date::Calc::Add_Delta_YMDHMS(@now[0..5],
                                             $tzone[0] * -1,
                                             $tzone[1] * -1,
                                             $tzone[2] * -1,
                                             $tzone[3] * -1,
                                             $tzone[4] * -1,
                                             $tzone[5] * -1);
    print "LOCAL->GMT : ";
    print sprintf("%04d-%02d-%02d %02d:%02d:%02d",@now);
    print " -> ";
    print sprintf("%04d-%02d-%02d %02d:%02d:%02d",@now_2),"\n";
}

perlの日付&時間計算module (Date::Calc , DateTime)の比較

perlの日付&時間計算module (Date::Calc , DateTime)の比較

http://search.cpan.org/dist/Date-Calc/ http://search.cpan.org/dist/DateTime/

主に Date::Calc を使っていますが、本日時点(2016/11/14)で、自分が気になるポイントを比較しています。

2016/11/14時点 Date::Calc DateTime
最新VER 6.4 1.4
最終更新 2015/3 2016/11
Rating 3.5 4.5
日付チェック check_date($y,$m,$d) DateTime->new(...) が失敗
現在日時 @ymd_hms=Today_and_Now() $dt_obj=DateTime->now()
日付の差分 $days=Delta_Days(@ymd1,@ymd2) $dlt_dt=$dt1->delta_days( $dt2 ); $dlt_dt->days;
?日後 @ymd=Add_Delta_YMD(@ymd, @dlt_ymd) $dt_2=$dt->add(months=>2, days=>3);
月の日数 $days = Days_in_Month($y,$m) $dt_obj=DateTime->last_day_of_month(year=>2008,month=>2); $dt_obj->day;

DateTimeは現在も定期的?にメンテされているので、移行しようかとも思いましたが、私が普段行っている日付計算程度であれば、Date::Calcのstaticコマンドで十分...

s3cmd 経由による javascript (ajax)で利用できる簡易なs3 web api

が欲しくなったので、メモ。

s3cmd で、テキストやbase64な画像ファイルをput/get な感じです

s3 ...というより IAM( Identity and Access Management ) の設定

以下の3つのポリシーを作成し、利用するユーザ等にアタッチさせます。

1番目の全バケット(*)に対する ListAllMyBuckets は、s3cmdが設定を行う為に必要です。 2,3番目で test-foo-backet に限定してますので、s3cmdが他のbacketに悪影響を及ぼすことはなさそうです。

Effect: Allow
AWS Service: Amazon S3
Actions: ListAllMyBuckets
Amazon Resource Name(ARN): arn:aws:s3:::*

Effect: Allow
AWS Service: Amazon S3
Actions: All Actions Selected
Amazon Resource Name(ARN): arn:aws:s3:::test-foo-backet

Effect: Allow
AWS Service: Amazon S3
Actions: All Actions Selected
Amazon Resource Name(ARN): arn:aws:s3:::test-foo-backet/*

s3cmd の準備 (install & configure)

# yum -y --enablerepo epel install s3cmd
$ s3cmd --configure

「s3cmd --configure」では、Access Key や Secret Key の入力を求められますが、 これらは、AWSマネージメントコンソールの IAM > ユーザ > アクセスキーの管理 で、発行して下さい。(ただ...アクセスキーは、2個/ユーザまでです)

ここから先はsrcを貼ります

development.pl

use File::Spec;
use File::Basename qw(dirname);
my $basedir = File::Spec->rel2abs(File::Spec->catdir(dirname(__FILE__), '..'));
my $dbpath = File::Spec->catfile($basedir, 'db', 'development.db');
+{
  aws_s3 =>
  {content_backet=>'test-backet',
   s3cmd =>'/usr/bin/s3cmd',
   s3cmd_conf =>'/home/endo/.s3cfg',
   backet_cache_dir =>'/home/endo/dev_data/TestAmon2/backet_cache',
  }
};

html template

: cascade "include/Layout.html"

: override head_content -> {
<title>AWS S3 API</title>
: }

: override body_main_content -> {
  <form id="main_form" method="post">
    BASE FOLDER<input type="text" id="base_folder" value="testfolder">
    ユーザID   <input type="text" id="uid"         value="xxx7654321">
    <hr>
    <input type="text" id="form_1" value="HOGE1">
    <input type="text" id="form_2" value="ほげ2">

    <button type="button" onClick="aws_s3.save_txt_data()">UPLOAD TXT</button>
    <button type="button" onClick="aws_s3.load_txt_data()">DOWNLOAD TXT</button>
    <button type="button" onClick="aws_s3.ls_data()"      >LISTING DATA(ls)</button>
    <hr>

    <input type="file" id="file_1" style="display:inline; width:350px;">

    <button type="button" onClick="aws_s3.chk_image()">CHECK IMAGE</button>
    <button type="button" onClick="aws_s3.save_image()">UPLOAD IMAGE</button>
    <button type="button" onClick="aws_s3.load_image()">DOWNLOAD IMAGE</button>
    <table class="table table-bordered">
      <tbody>
    <tr>
      <th style="width:100px;">file名</th>
      <td style="width:150px;"id="file_name"></td>
      <th style="width:100px;">mime type</th>
      <td style="width:150px;" id="file_type"></td>
      <th style="width:150px;">file size (byte)</th>
      <td style="width:150px;" id="file_size"></td>
    </tr>
      </tbody>
    </table>
    <img id="thumb_nail" width="400">
    <div id="img_test"></div>

  </form>
: }


: override body_sub_content -> {
: }

: override foot_content -> {
<script src="/static/js/jquery.cookie.js"></script>
<script src="/static/js/aws_s3_api.js"></script>
<script>
 $(document).ready(function(){
   aws_s3.set_base_folder( $('#base_folder').val() );
 });
</script>
: }

javascript

(function() {
    var AwsS3Api = function(){};
    
    AwsS3Api.prototype = {

        chk_image: function(){
            if(! window.File || ! window.FileReader) {
                alert("このブラウザはFile APIをサポートしていません");
                return;
            }
        // jQueryオブジェクトから、元のhtmlオブジェクトを抽出
            var file = $('#file_1').get(0).files[0];
            if(! file || ! file.type.match(/image/)) {
                alert('画像ファイルを選択下さい');
                return;
            }
            $('#file_name').html( file.name );
            $('#file_type').html( file.type );
            $('#file_size').html( file.size );

            var reader = new FileReader();
            var this_obj = this;
            reader.onload = function(evt) {
                $("#thumb_nail").attr('src',reader.result);
                $("#thumb_nail").css('display','block');
            };
            reader.readAsDataURL(file);

        },
        
        save_image : function (){
            var mime_type = $('#file_type').text().split('/');
            if( mime_type[0] != 'image'){
                alert('画像ファイルを選択下さい');
                return;
            }
            
            var data = { 'XSRF-TOKEN': $.cookie('XSRF-TOKEN') };
            var this_obj = this;
            var uid = $('#uid').val();
            var filename = uid + "_base64_image.txt";
            var path =
                [this.base_folder, this.calc_user_path( uid ), filename].join('/');
            var url = '/awss3/put/' + path;

            data.content = $("#thumb_nail").attr('src');

            $.ajax({url: url,
                    type: 'POST',
                    data: data,
                    success: function(data,txt_status,xhr){
                        if(data.result != 'OK'){
                            alert('処理が失敗しました');
                            return;
                        }
                        alert('処理が完了しました');
                    },
                    error: function(data,txt_status,xhr){
                        alert('処理が失敗しました');
                    }
                   });
        },

        load_image : function (){
            var data = { 'XSRF-TOKEN': $.cookie('XSRF-TOKEN') };
            var this_obj = this;

            var uid = $('#uid').val();
            var filename = uid + "_base64_image.txt";
            var path =
                [this.base_folder, this.calc_user_path( uid ), filename].join('/');
            var url = '/awss3/get/' + path;

            $.ajax({url: url,
                    type: 'POST',
                    data: data,
                    success: function(data,txt_status,xhr){
                        if(data.result != 'OK'){
                            alert('処理が失敗しました');
                            return;
                        }
                        $("#thumb_nail").attr('src', data.content);
                        alert('処理が完了しました');
                    },
                    error: function(data,txt_status,xhr){
                        alert('処理が失敗しました');
                    }
                   });
        },

        set_base_folder: function(base_folder){
            this.base_folder = base_folder;
        },

    //複数ユーザのファイルを1個のdirに登録すると、lsがスゴそうですので...
        calc_user_path: function( uid ){
            //ex. uid = uid123456 + chk digit
            var m = uid.match(/^(uid\d\d\d)\d\d\d/i);
            if( m[1] ){
                return m[1].toLowerCase();
            }
            return 'other';
        },

        save_txt_data : function (){
            var data = { 'XSRF-TOKEN': $.cookie('XSRF-TOKEN') };
            var this_obj = this;

            var uid = $('#uid').val();
            var filename = uid + "_answer.txt";
            var path =
                [this.base_folder, this.calc_user_path( uid ), filename].join('/');
            var url = '/awss3/put/' + path;
            data.content = [ $('#form_1').val().replace(/\t/g, ' '),
                             $('#form_2').val().replace(/\t/g, ' ')].join("\t");
            $.ajax({url: url,
                    type: 'POST',
                    data: data,
                    success: function(data,txt_status,xhr){
                        if(data.result != 'OK'){
                            alert('処理が失敗しました');
                            return;
                        }
                        alert('処理が完了しました');
                    },
                    error: function(data,txt_status,xhr){
                        alert('処理が失敗しました');
                    }
                   });
        },

        load_txt_data : function (){
            var data = { 'XSRF-TOKEN': $.cookie('XSRF-TOKEN') };
            var this_obj = this;

            var uid = $('#uid').val();
            var filename = uid + "_answer.txt";
            var path =
                [this.base_folder, this.calc_user_path( uid ), filename].join('/');
            var url = '/awss3/get/' + path;

            $.ajax({url: url,
                    type: 'POST',
                    data: data,
                    success: function(data,txt_status,xhr){
                        if(data.result != 'OK'){
                            alert('処理が失敗しました');
                            return;
                        }

                        var cols = data.content.split("\t");

                        $('#form_1').val(cols[0]);
                        $('#form_2').val(cols[1]);

                        alert('処理が完了しました');
                    },
                    error: function(data,txt_status,xhr){
                        alert('処理が失敗しました');
                    }
                   });
        },
        
        ls_data : function (){
            var data = { 'XSRF-TOKEN': $.cookie('XSRF-TOKEN') };
            var this_obj = this;

            var uid = $('#uid').val();
            var filename = uid + "_answer.txt";
            var path =
                [this.base_folder, this.calc_user_path( uid ), filename].join('/');
            var url = '/awss3/ls/' + path;

            $.ajax({url: url,
                    type: 'POST',
                    data: data,
                    success: function(data,txt_status,xhr){
                        if(data.result != 'OK'){
                            alert('処理が失敗しました');
                            return;
                        }

                        alert( data.content );
                    },
                    error: function(data,txt_status,xhr){
                        alert('処理が失敗しました');
                    }
                   });
        }
    };
    window.aws_s3 = new AwsS3Api();
})();

Controller (perl)

package TestAmon2::Web::Dispatcher::AwsS3Api;
use strict;
use utf8;
use base qw/TestAmon2::Web::Dispatcher/;
use Data::Dumper;       # for debug write
use TestAmon2::Model;
use TestAmon2::Web::View;


sub new {
    my ($class) = @_;
    my $self = {};
    $self =  bless $self, $class;
    return $self;
}

sub do_main {
    my ($self,$c) = @_;

    $self->{c} = $c;
    $self->{user_id} = $self->get_login_user_id($c);
    my $path_info_str = $c->req()->{env}->{PATH_INFO};

    unless( $path_info_str =~ m{^/awss3/([^/]+)/(.*)}o ){
        return $self->do_index_page($c);
    }
    my $action =  $1;
    my $s3_path = $2;

    if($action eq 'ls' or
       $action eq 'get' or
       $action eq 'put'
      ){
        my $method = "do_".$action;
        return $self->$method($c, $s3_path);
    }

    return $self->do_index_page($c);
}

sub do_index_page {
    my ($self, $c) = @_;

    my $render_data = {};
    $render_data->{c} = $c;
    my $view = TestAmon2::Web::View::AwsS3Api->new();

    return $view->render_index_page($c, $render_data);
}

sub do_put {
    my ($self, $c,$s3_path) = @_;

    my $render_data = {};
    $render_data->{c} = $c;
    my $view = TestAmon2::Web::View::AwsS3Api->new();

    my $m_aws_s3 = TestAmon2::Model::AwsS3->new($c);

    my $result = $m_aws_s3->cmd_put($s3_path,
                                    $c->req->param('content'));
    if ($result){
        return $c->render_json( {result=>'OK'});
    }
    return $c->render_json( {result=>'NG'});
}

sub do_get {
    my ($self, $c,$s3_path) = @_;

    my $render_data = {};
    $render_data->{c} = $c;
    my $view = TestAmon2::Web::View::AwsS3Api->new();

    my $m_aws_s3 = TestAmon2::Model::AwsS3->new($c);
    $render_data->{content} = $m_aws_s3->cmd_get($s3_path);

    if(not defined($render_data->{content})){
        return $c->render_json( {result=>'NG'});
    }
    return $c->render_json({result=>'OK',
                            content=> $render_data->{content}});
}

sub do_ls {
    my ($self, $c,$s3_path) = @_;

    my $render_data = {};
    $render_data->{c} = $c;
    my $view = TestAmon2::Web::View::AwsS3Api->new();

    my $m_aws_s3 = TestAmon2::Model::AwsS3->new($c);
    $render_data->{content} = $m_aws_s3->cmd_ls($s3_path);

    if(not defined($render_data->{content})){
        return $c->render_json( {result=>'NG'});
    }
    return $c->render_json({result=>'OK',
                            content=> $render_data->{content}});
}

1;
__END__

Model (perl)

s3に対するput/getは遅いので、ec2側にもcacheしています

package TestAmon2::Model::AwsS3;
use strict;
use utf8;
use base qw/TestAmon2/;
use Cwd;
use File::Path qw/mkpath rmtree/;
use File::Temp;
use MIME::Base64;
use Data::Dumper;       # for debug write

my $CONF = TestAmon2->config;
my $S3CMD = $CONF->{aws_s3}->{s3cmd};
my $S3CMD_CONF = $CONF->{aws_s3}->{s3cmd_conf};
my $BACKET = $CONF->{aws_s3}->{content_backet};
my $CACHE_LIMIT_AGE = 60 * 5; #sec


# http://*.com/awss3/get $BACKET/$FOLDER/$FILE
# s3cmd ls s3://バケット名
# s3cmd put オブジェクト名 s3://バケット名/
# s3cmd get オブジェクト名 s3://バケット名/
# s3cmd del オブジェクト名 s3://バケット名/

sub new {
    my ($class, $c) = @_;

    my $self = {c=>$c};
    $self =  bless $self, $class;
    return $self;
}

sub open_localfile {
    my ($self, $path ) = @_;

    my $fh;
    unless( open($fh, '<', $path) ){
        $self->log_error("fail open $path");
        return;
    }

    local $/ = undef;
    my $content = <$fh>;

    unless( close($fh) ){
        $self->log_error("fail close $path");
        return;
    }
    
    if($path =~ /\.txt$/io ){
        $content = Encode::decode('utf8',$content);
    } else {
        $content = MIME::Base64::encode_base64($content);
    }
    
    return $content;
}


sub cmd_put {
    my ($self, $path, $content ) = @_;

    unless( $path =~ m|^(.+)/([^/]+)$|o){
        $self->log_error("fail parse dir/filename from $path");
        return;
    }
    my $parent_dir = $1;
    my $filename =   $2;

    my $cache_dir = join('/',$CONF->{aws_s3}->{backet_cache_dir},$parent_dir);
    my $cache_path = "$cache_dir/$filename";

    if(not -d $cache_dir){
        unless( File::Path::mkpath($cache_dir)) {
            $self->log_error("fail mkpath $cache_dir");
            return;
        }
    }

    my $fh;
    unless( open($fh, '>', $cache_path) ){
        $self->log_error("fail open $cache_path");
        return;
    }
    print $fh Encode::encode('utf8', $content);

    unless( close($fh) ){
        $self->log_error("fail close $cache_path");
        return;
    }

    my $cmd = join(' ',
                   "$S3CMD --quiet --force --config=$S3CMD_CONF",
                   "put $cache_path s3://$BACKET/$parent_dir/");
    unless( open($fh, '-|', $cmd) ){
        $self->log_error("fail open $cmd");
        return;
    }

    unless( close($fh) ){
        $self->log_error("fail close $cmd");
        return;
    }

    return $path;
}

sub cmd_get {
    my ($self, $path ) = @_;

    unless( $path =~ m|^(.+)/([^/]+)$|o){
        $self->log_error("fail parse dir/filename from $path");
        return;
    }
    my $parent_dir = $1;
    my $filename =   $2;

    my $cache_dir = join('/',$CONF->{aws_s3}->{backet_cache_dir},$parent_dir);
    my $cache_path = "$cache_dir/$filename";

    if(-e $cache_path ){
        my $now =   time();
        my $mtime = (stat($cache_path))[9];
        if(($now - $mtime) < $CACHE_LIMIT_AGE ){
            return $self->open_localfile($cache_path);
        }
    }

    if(not -d $cache_dir){
        unless( File::Path::mkpath($cache_dir)) {
            $self->log_error("fail mkpath $cache_dir");
            return;
        }
    }

    my $cmd = join(' ',
                   "$S3CMD --quiet --force --config=$S3CMD_CONF",
                   "get s3://$BACKET/$path $cache_dir/");
    my $fh;
    unless( open($fh, '-|', $cmd) ){
        $self->log_error("fail open $cmd");
        return;
    }

    unless( close($fh) ){
        $self->log_error("fail close $cmd");
        return;
    }

    unless(utime(undef,undef,$cache_path)){
        $self->log_error("fail utime(touch command) $cache_path");
        return;
    }

    return $self->open_localfile($cache_path);
}

sub cmd_ls {
    my ($self, $path ) = @_;

    my $cmd = join(' ',"$S3CMD --config=$S3CMD_CONF","ls s3://$BACKET/$path");
    my $fh;
    unless( open($fh, '-|', $cmd) ){
        $self->log_error("fail open $cmd");
        return [];
    }

    my @ret;
    while(my $line = <$fh>){
        chomp($line);
        my @cols = split(/\s\s+/, $line);

        $cols[2] =~ s|s3://$BACKET/||o;
        if( $cols[1] eq 'DIR'){
            push(@ret,[$cols[2]]);
        } else {
            push(@ret,[$cols[2],$cols[1],$cols[0]]);
        }
    }
    
    unless( close($fh) ){
        $self->log_error("fail close $cmd");
        return [];
    }
    return \@ret;
}

1;
__END__

View (perl)

package TestAmon2::Web::View::AwsS3Api;
use strict;
use utf8;
use base qw(TestAmon2::Web::View);
use Data::Dumper;       # for debug write

sub new {
    my ($class) = @_;
    my $self = {};
    $self =  bless $self, $class;
    return $self;
}

sub render_ls {
    my ($self, $c, $render_data) = @_;
    return $c->render_json( {body=>$render_data->{paths}});
}

sub render_get {
    my ($self, $c, $render_data) = @_;
    return $c->render_json( {body=>$render_data->{content}});
}

sub render_index_page {
    my ($self, $c, $render_data) = @_;
    return $c->render('AwsS3Api/Index.html', $render_data);
}

1;
__END__