--POE

#!/usr/local/bin/perl -w
use strict;use threads;use threads::shared;# 线程用来为 GUI 服务的，没啥别的意思。
# POE 自己就够强了，能够解决多线索的 SMPP 通讯协议转发问题
use Win32::GUI;use Win32 ();use Win32::GUI::Loft::Design;# Loft 实在是 windows perl 的 MVC 的居家必备
use Data::HexDump;# 用来在小黑窗滚动打印那些看来很专业的 hex 数据包 dump
use Time::HiRes;# 没啥用处，喜欢精确的个性使然
use POE qw(Component::Server::TCP Component::Client::TCP Filter::Stream Filter::Block );# 发现 Filter  Block 是个惊喜，用来解决数据包打头的大小字段的打包解包问题，pack 在这点上还是不够 handy

my $fileWindow = "C:\\test.gld";    #You created this using The GUI Loft
my $objDesign = Win32::GUI::Loft::Design->newLoad($fileWindow)  or die("Could not open window file ($fileWindow)");my $win = $objDesign->buildWindow()  or die("Could not build window ($fileWindow)");# 从设计好的 .gld 文件来重新建立窗口

my $min = 0;my $icon = new Win32::GUI::Icon('c:\\pxperl\\bin\\pxperl.ico');my $ni = $win->AddNotifyIcon(   -name   => "NI", -id => 1,                                -icon   => $icon,                                -tip    => "短信");# 再来个托盘最小化图标，弄得专业一点

$win->Show();Win32::GUI::Dialog();# 窗口上现在应该有：开始、最小化(hide)、退出三个按钮，老板不挑剔的话已经足够了

sub ::winmsg_Terminate {    return (-1);}sub ::btnhide_Click {    defined( my $win = $Win32::GUI::Loft::window{winmsg} ) or return (1);    $win->Disable() unless $min;    $win->Hide() unless $min;    $min=1;    return (1);}sub ::btnquit_Click {    return (-1);}# 返回 -1 就是最小化了

sub NI_Click {    defined( my $win = $Win32::GUI::Loft::window{winmsg} ) or return (1);    if ($min) {        $win->Enable(); $win->Show(); $min=0; return(1);    } else {        $win->Disable(); $win->Hide(); $min=1; return(1);    };}# 从托盘怎么唤醒小窗口

sub ::btnok_Click {    defined( my $win = $Win32::GUI::Loft::window{winmsg} ) or return (1);    async {        my ( $retrytime, $seq, $bnd, %clients) = ( 1, 16, 0, 0, undef);        POE::Component::Server::TCP->new (            Port => 19231,            ClientInput => sub {                my ($kernel, $heap, $input) = @_[ KERNEL, HEAP, ARG0];                warn $input;                $kernel->yield(q(shutdown)) if ($input =~ /quit/);                $kernel->stop() if ($input =~ /kill/);            },        );       # 用 telnet 遥毙程序，故作神秘
        sub enc {            my $stuff = shift;            substr($$stuff, 0, 0) = pack q(N), 4+length($$stuff);            warn HexDump $$stuff;            return;        };        sub dec {            my $stuff = shift;            return unless length($$stuff) >= 4;            return unpack(q(N), $$stuff);        };       # 前面说的 pack 的软肋就在这里用下面的 Filter::Block 的两个打包拆包处理器解决了
        POE::Component::Server::TCP->new (            Port            => 1314,            ClientFilter    => ["POE::Filter::Block", LengthCodec => [\&enc, \&dec]],            ClientConnected => sub {            },            ClientDisconnected => sub {                my $clid = $_[SESSION]->ID();                delete $clients{$clid};                warn "smpp client $clid stopped";            },            # 客户退出例行告警，没啥实际用处，可以拓展成其他形式的意外 alert
            ClientInput     => sub {                my ($kernel, $heap, $input) = @_[ KERNEL, HEAP, ARG0];                my $cmd = unpack 'N', substr($input, 4, 4);                if ( $cmd == 0x00000004 ) {                    my (undef, undef, $subseq, $subfrom, $subto, $esm, $code, $body) =                        unpack q(N2xx![N]N x(x2Z*)2Cx6CxC/A*), $input;                    # 不懂就赶快去看 packtut 和 Net::SMPP 两个 perldoc
                    $heap->{client}->put(                        pack q(N3 Z*), 0x80000004, 0, $subseq, q(1a2b3c4d));                    #  成功发送的 ack 发送出去了，其实不是这里干的，而是在下面用 proxysub 真的在发送短信，否则怎么叫短信代理呢？
                    $kernel->post(q(smppproxy), q(proxysub), $subto, $body);                } elsif ( $cmd == 0x80000005 ) {                    my (undef, undef, $delstat, $delseq, $delid) =                        unpack q(N4 Z*), $input;                    warn "submit nok for sms #$delseq" if $delstat;                    warn "$delseq => $delid";                } elsif ( $cmd == 0x00000001 ) {                    my (undef, undef, $bndseq, $bndname, $bndpass, $ver) =                        unpack q(N2xx![N]N (Z*)2xCx3), $input;                    return if $bndname != $bndpass;                    # 没错，我们公司也是这样 root/root 的密码
                    $heap->{client}->put(                        pack q(Nxx![N]N Z*), 0x80000001, $bndseq,q(bustaxi));                    my $clid = $_[SESSION]->ID();                    $clients{$clid} = "alive";                    # alive 就是说以后真有短信过来可以投递给他们了，解决了 POE::Component::TCP::Server 只能发信不能投递的问题， thanks POE maillist
                    warn "smpp client $clid started & passed test";                }            },            InlineStates    => {                scatter => sub {                    my ( $heap, $kernel, $dlvto, $dlvwhat ) =                        @_[HEAP, KERNEL, ARG0, ARG1];                    $heap->{seq} ++;                    warn "scatter get called $heap->{seq}";                    $heap->{client}->put( pack q(Nxx![N]N x(x2Z*)2Cx6CxC/A*),                                            0x00000005, $heap->{seq},                                            q(86801), $dlvto, 0, 0, $dlvwhat);                    # 发信时候请丢在这里，邮筒的名字叫做 scatter，没错就是 foxpro 里面那个 gather 的搭档
                },
            },
        );
        POE::Component::Client::TCP->new (            Alias           => q(smppproxy),            Filter          => ["POE::Filter::Block", LengthCodec => [\&enc, \&dec]],            RemoteAddress   => qq(197.197.11.5),            RemotePort      => 5018,            Alias           => q(1st),            ConnectTimeout  => 100,            Connected       => sub {                my ( $kernel, $heap) = @_[ KERNEL, HEAP];                ($retrytime, $seq, $bnd) = ( 1, 16, 1);                warn "connected";                my  ( $bndrcv, $id, $passwd, $bndrcvlen) =                    ( undef, 'bustaxi', 'bustaxi', undef, 9);                $bndrcv = pack q(Nxx![N]N (Z*)2xCx3), 0x00000001, $seq,                                                      $id, $passwd, 0x33;                $heap->{server}->put($bndrcv);                $kernel->delay(heartbeat => 20);            },            # 能够发信之前你得先有腰牌，还得有心跳
            ConnectError    => sub {                my ($kernel, $heap, $err) = @_[ KERNEL, HEAP, ARG1];                $retrytime = ($retrytime > 60) ? 2 : ($retrytime *2);                warn "reconnecting again after $retrytime sec(s) for $err";                $kernel->delay(reconnect => $retrytime);            },            # 别总是一陈不变的定时重试，服务器没准会厌烦的
            Disconnected    => sub {                warn "reconnecting";                my ($kernel, $heap) = @_[ KERNEL, HEAP];                $bnd = 0;                $kernel->yield( "reconnect" );            },            # 被踢出来是正常的，别灰心我们可以自动重连的
            ServerInput     => sub {                my ($kernel, $heap, $input) = @_[ KERNEL, HEAP, ARG0];                warn "servre said";                warn HexDump $input;                # 满屏幕是你说我说他说，有了代理就热闹很多了
                my $cmd = unpack 'N', substr($input, 4, 4);                if ( $cmd == 0x00000005 ) {                    my (undef, undef, $dlvseq, $dlvfrom, $dlvto, $esm, $code, $body) =                        unpack q(N2xx![N]N x(x2Z*)2Cx6CxC/A*), $input;                    $heap->{server}->put(                        pack q(N3 Z*), 0x80000005, 0, $dlvseq, q(1a2b3c4d));                    foreach my $clid (keys %clients) {                        warn "posting to $clid";                        $kernel->post($clid => scatter => $dlvfrom => $body);                    }                    # 挨家挨户骑车投递信件
                } elsif ( $cmd == 0x80000004 ) {                    my (undef, undef, $substat, $subseq, $subid) =                        unpack q(N4 Z*), $input;                    warn "submit nok for sms #$subseq" if $substat;                    warn "$subseq => $subid";                # 看看挂号信的回执是不是正常
                } elsif ( $cmd == 0x80000001 ) {                    my (undef, undef, $bndstat, $bndseq) =                        unpack q(N4 Z*), $input;                    warn "bind receiver nok for req #$bndseq" if $bndstat;                # 还得留神腰牌验证通过了没有
                } elsif ( $cmd == 0x80000015 ) {                    my (undef, undef, $enqstat, $enqseq) =                        unpack q(N4 Z*), $input;                    warn "enqlink nok for req #$enqseq" if $enqstat;                }                # 大家都得有心跳，服务器那里给我们心跳回执，下面就是保持心跳的事件
            },
            InlineStates => {                heartbeat   => sub {                    my ( $heap, $kernel ) = @_[HEAP, KERNEL];                    $heap->{server}->put( pack q(Nxx![N]N), 0x00000015, ++$seq) if $bnd;                    $kernel->delay(heartbeat => 20);                },                proxysub    => sub {                    my ( $heap, $kernel, $subto, $subwhat ) =                        @_[HEAP, KERNEL, ARG0, ARG1];                    $heap->{server}->put( pack q(Nxx![N]N x(x2Z*)2Cx6CxC/A*),                                            0x00000004, ++$seq,                                            q(86800), $subto, 0, 0, $subwhat);                },                # 邮局这个辰光才真的装车
            },
        );
        POE::Kernel->run();
    };
    $win->btnok->Text(q(再来));    return (1);
}

 

 

 

 

google上的链接：
https://docs.google.com/Doc?docid=df26q2xp_82gr83z7&hl=en