# 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