说起来， pdk 的更新算是挺勤快的，一转眼到 7.3 了。其中有一个功能就是用来创建 win 下的系统服务的，但首先必须要遵循一些规则。

具体的可以在帮助文档里找到，这里只是简要地说明一些必要的东西，并举一个例子来说明。有三个东西时一定要定义的，分别是 $PerlSvc::Name 、 $PerlSvc::DisplayName 和 PerlSvc::startup() ，即服务名称、控制面板中显示的服务名称和主程序（也就是服务启动时要运行的程序）。其他的都是可有可无的，对于这么一个简单的东西，完全没有必要。

package PerlSvc;

our %Config;

sub Startup {

    while (ContinueRun()) {

       $local_addr=pack('SnC4x8', 2, 32080, 127,0,0,1);

       socket(FILE_TRANS_SERV, 2, 1, getprotobyname('tcp')) or die("socket failed for $!");

       bind(FILE_TRANS_SERV, $local_addr) or die("bind failed for $!");

       listen(FILE_TRANS_SERV,3);

       $remote_addr = '';

       for(; $remote_addr=accept(FILE_TRANS_CLIENT,FILE_TRANS_SERV); close(FILE_TRANS_CLIENT)){

           $in = <FILE_TRANS_CLIENT>;

           while (<FILE_TRANS_CLIENT>) {}

           if ($in =~ 'shutdown') {

              close(FILE_TRANS_CLIENT); close(FILE_TRANS_SERV);

              system "shutdown -s -t 0";

           }

       }

       close(FILE_TRANS_SERV);

    }

}

sub Pause { }

sub Continue { }

sub Interactive { }

sub Help { }

sub Install {

    $Config{ServiceName} = 'MyShutdownService';

    $Config{DisplayName} = 'My Shutdown Service';

}

sub Remove {

    $Config{ServiceName} = 'MyShutdownService';

}

package main;

1;

在 startup 中，我开了一个监听 socket ，等待接收关机指令，另外最好将socket的建立和注销过程写在一个while循环中，避免不必要的逻辑错误。在 Install 中定义了两个服务名称。

每种语言都有其擅长和不足的地方，在某项工作甚至工作的某一部分中选择合适的语言往往可以达到事半功倍的效果。所以，多掌握一些知识是很有必要的，当然了也可以用一些大语言，比如说 C 或者 Java ，它们几乎是可以通吃一切问题的，但是付出的代价一样高昂，一些可以用几行 Perl 或者 Python 实现的功能，换作 Java 可能需要花费几倍的工作量，所以这里就不谈了。

在很久以前，为了方便工作人员录制电视节目，我用 Perl 写了一个基于 Tk 的设置界面。界面如下图：

大致上就是设置一个时间，然后在该时间点自动启动一个录制程序。当时由于时间仓促，本着够用就好的精神，很快就写好了，所以难免留下一些 bug 。比如说设置完之后，没有将按钮重置为退出。这还是小事，最主要的还是一旦录制程序启动，整个界面就被阻塞，这是 windows 下 Perl 的老毛病了，几乎无药可救。

其实即便如此，这个程序还是可以顺利使用的，但是作为一个解决长时间运算阻塞界面的办法，将它移植到 Tcl 上，还是有一些意义的。在上一篇随笔中，我大致讲到了 filevent 和 select 在 windows 下的差别，正好可以在这里验证一下，同时通过移植的过程，也可以更清楚地了解和区分两种语言在某些功能上的不同实现办法。最终实现的工具如下图 ：

这里将代码拆分开来进行分析。

首先是界面部分，这一部分其实是最简单的，所以在实现上几乎一样，只不过是语法上的差别而已。有一点值得注意的是 Tcl 中是不需要的 mainloop 这样的命令来显式地启动主循环。

第二，因为定时启动需要计算启动时间与当前事件的差值，所以需要处理一些时间相关的参数。 Perl 中可以使用 localtime 来得到年份、月、日和秒等共 9 个值，供组合使用。在 Tcl 中，有一个 clock 命令，通过 format 可以实现类似的功能，感觉上 Tcl 的更方便一些。相同的感觉也处理时间差值时也存在，因为 Perl 中需要拆分一个某种形式的时间表达式，提取必要参数给 timelocal 计算总秒数，而 Tcl 的 clock 有 scan 可以直接生成。

第三，在像 Perl 的 BrowseEntry 和 Tcl 的 ComboBox 的下拉框中，经常会插入一串连续的数字。 Perl 可以使用形如“（ 1..10 ）”来表示 1-10 这 10 个数字，但是在 Tcl 里没有类似的命令，所以当遇到大数组表达式的时候，最好是写一个方法来模拟 Perl 中的这种功能。

第四，为了确保录制任务在制定的时间点启动，需要有检查是否超时。在 Tcl 里这个实现因为有 after 变得很轻松，只要指定一个需要等待时间戳， Tcl 就会在过晚这段时间之后启动需要执行的指令，而 Perl 就麻烦多了。在 Tk 的 mainloop 中，使用 repeat(1000, sub {…}) 使其每隔一秒钟执行一次检查，看是否超时。一旦检查到超时则停止检查并启动录制；若没有则提示继续下次检查。

第五，在如何启动录制这点上，两者使用了不同的手段。 Tcl 使用管道来启动进程，使得自身不被阻塞（不过在使用producer的时候还是会阻塞，用ping就没问题，这个很奇怪），并且使用 filevent 监测打开句柄的状态。而 Perl 因为不可靠的 select ，我们只能使用 system ，通过阻塞的办法来获知任务是否完成，这也是一个无可奈何的事情了。

（代码下载）

因为在用  Perl-Tk  或者  Socket  时，经常会需要监视某些打开的句柄而不至于阻塞主循环， 对于这些 win32  下的 Perl 表现远不如 Linux 下来得得心应手，但这时候我基本没有什么办法。这和 windows 的底层 select 实现有关，而 Perl 恰恰是调用它的，但我一直认为肯定有别的替代办法，因为 Tcl/Tk 的 fileevent 就表现得很好。

下面是一个例子，用来显示  ping  的结果。这里有两个组件，一个是按钮，用来开始和停止  ping  ；另一个是  text  用来显示  ping  的结果。分别用  Perl  和  Tcl/Tk  代码来实现，看看他们有什么不同。

use Tk;

$count = 4;

$host = '127.0.01';

$mw = MainWindow->new;

$bt = $mw->Button(-text => 'Clink to start ping', -command => \&RunPing);

$bt->pack(-fill => 'x');

$tx = $mw->Text(-width => 50, -height => 30);

$tx->pack;

MainLoop;

sub RunPing {

   open $fd, "ping -n $count $host|";

   $mw->fileevent($fd, 'readable' => sub {

      sysread $fd, $buf, 30;

      $tx->insert('end', $buf);

      });

   $bt->configure(-text => 'close', -command => \&ClosePing);

}

sub ClosePing {

   close $fd;

   undef $fd;

   $bt->configure(-text => 'Clink to start ping', -command => \&RunPing);

}

运行的结果很让人失望，在  readable  的事件中加入  print  后而已更清楚地看到，事实上  readable  事件是没有被触发过的。这里的  fileevent  是  Tk  中处理事件触发的函数，它为句柄的两个状态（  readable  ，  writable  ）设定触发函数，其本质上使用了系统的  select  或者  poll  ，换句话说即便是用  Perl  的  select  或者  IO::Seelct  也是于事无补。文档里的原话佐证了这点“  A file is considered to be readable on same basis as the system's select() (or poll()).  ”。

所以可以这么讲，  win32  下的  Perl  是不大适合处理事件响应的，因而也就很难处理好处理网络相关或者界面需要运行后台长时间操作的情况。接下来换作是使用  Tcl/Tk  来实现这一功能，值得一提的是在  Perl  下  50  宽度的  button  和  text  是不等长的，所以索性在  pack  里用  fill  自动拓宽了，而在  Tcl/Tk  中没有这个问题。

package require Tk

set pingcount 4

set host {127.0.0.1}

button .btn -text {Clink to start ping} -command "RunPing $host $pingcount" -width 50

text .text -width 50 -height 30

pack .btn .text

proc RunPing {host count} {

   set fd [open "|ping -n $count $host"]

   ;#fconfigure $fd -blocking 0

   fileevent $fd readable "onPingRead $fd $count $host"

   .btn configure -text "close" -command "closeFd $fd $count $host"

}

proc onPingRead {fd count host} {

   if {[eof $fd]} {

      closeFd $fd $count $host

   } else {

      set buf [gets $fd]

      .text insert {end} "$buf\n"

   }

}

proc closeFd {fd count host} {

   close $fd

   .btn configure -text {Clink to start ping} -command "RunPing $host $count"

}

为了使用同样条件的管道，屏蔽了设置非阻塞的代码行，但这么作   因为系统不得不等待管道中的进程运行结束，所以   也使得  close  没有起到应有的作用。

运行的结果很令人满意，  test  没有被阻塞，在显示  ping  结果的同时，依然可以在  text  中执行输入，而且  button  也可以被顺利按下。这么看来  Tcl/Tk  比之  Perl  在  win32  下，显然在事件处理上占有优势，而且这个占优的方面是极其重要的。

不得不说的是   google   上搜索出来的竟然都是《   perl   在   win32   平台上直接操作打印机》，这是非常令人抱歉的文章。很显然是初学者写的，如果连这个都不知道，我还真是佩服他怎么学   perl   的了，这不是单指   win32   下的打印办法，哪里都一样。但是这太简陋了，不是我想要的。  

当然了，在   avtivePerl   中你可以使用   ppm   下载   Printer   来打印，但是当你看见那可怜的文档后，也许会打消这个念头，或者打印一些   text   是再好不过了。或者使用   cpan   安装   Win32::Word::Writer   来打印，我想它是非常好的，但前提是你能装的上它，而我在   win32   下装不上。  

这个问题事实上困扰了我很久，因为很多时候你写的   tk   界面脚本，需要将分析的数据打印出来，如果不将这个功能集成进脚本，便不得不求助于其他的工具，比方说先生成一个文档，然后用   openoffice   或者其他打开它，最后在其中实现打印，这非常麻烦，而且也不容易让使用者接受。  

既然没有特别好的针对性工具，我变依照上面的流程模拟这个过程，但这一切都是在内存中实现的，因此对于用户，不会知道里面的实现细节，这样很好。首先我用   Win32::OLE   打开一个文档，要保证它是不被   visiable   。之后将需要打印的文档按照其中的格式，打入到这个文档中。最后打印出来。不过可能是   OLE   的   bug   ，这样做会在内存中保留一个到该文档的句柄，在关机的时候不有提示出错，而且如果在程序中直接使用   close   的话，会弹出对话框询问是否保存，这就做不到隔离使用者的效果了。所以，使用   saveas   将文档存到   disk   里，这算是一个无奈的妥协。下面是我在集群文档编辑系统中的用于打印的一个函数：  

sub file_print {

    my  $cur_style   =  ' a ' ;

    my  $word        =

      Win32 :: OLE -> new( ' Word.Application ' ,  ' Quit ' ) or die $ ! ;

    $word -> { ' Visible ' } =  0 ;

    my  $document    =  $word -> Documents -> Add;

     my  $selection   =  $word -> Selection;

    my  $style       =  $document -> Styles -> Add( $cur_style );

    my  $style_font  =  $style -> {Font};

    $style_font -> {Name}                         =  $family ;

    $style_font -> {Size}                          =  $size ;

    $style_font -> {Bold}                         =  $weight ;

    $style_font -> {Italic}                       =  $slant eq ' italic '  ?  1  :  0 ;

    $style_font -> {Underline}                    =  $underline ;

    $document -> ActiveWindow -> Selection -> {Style} =  $cur_style ;

    $selection -> TypeText( $textundo -> get( ' 1.0 ' ,  ' end ' ) );

    $word -> ActiveDocument -> PrintOut;

    $document -> SaveAs( ' printout.doc ' );

    $document -> Close ;

    $word -> Quit;

}

因为   tk   下的   font   和   word   中的有些不兼容，所以做了一些变换，比如说对于   slant   ，   tk   是用   ‘italic’   和   ‘roman’   的，相对于   word   就是布尔值了。

这里讲的两个都是非标准组件，所以一般都是建立在标准的   pTk   组件之上的，由纯   perl   代码写成的，因此也便于修改。  

第一个是   ToolBar   ，就是文件浏览器中的在菜单栏之下的，一般叫工具栏。   pTk   中的   ToolBar   标准支持   Button   ，   Label   ，   LabEntry   ，   OptionMenu   和自带的一个   separator   （这个还是很有用的）。如果要加入其他的组件，比如   BrowseEntry   ，   pack   之后会被   ToolBar   放到工具栏的第二行上，很不方便。现在我们来看看   ToolBar.pm   ，里面到底是怎么处理标准支持的。搜索到   ToolLabel   的   sub   ，里面的代码如下：  

sub ToolLabel {

   my $self = shift;

   my $l = $self->{CONTAINER}->Label(@_);

   push @{$self->{WIDGETS}} => $l;

   $self->_packWidget($l);

   return $l;

}

对比其他的几个   sub   ，我可以很肯定，只要将第四行中的   Label   改成   BrowseEntry   就可以了，这里缺少的一行是关于   tip   的，对于   BrowseEntry   来说，没有必要。  

第二个是   DateEntry   。就是一个日期选择器，很多时候我们会用到它。我再使用的时候发现了一个问题，就是在显示月份的地方，出现了乱码，打开   DateEntry.pm   一看，找到如下一段：  

my $monthlabel = (defined &strftime

         ? strftime($w->cget('-headingfmt'),0,0,0,1,

                $w->{_month}-1,$w->{_year}-1900)

         : $w->{_month} . "/" . $w->{_year}

        );

显然，它是用了   strftime   这个函数，去除选择，直接用冒号后的形式即可。  

还有，如何让在日期控件中的日期按钮被按下的时候响应一个事件。作为一般的控件这是一个必要的功能，但是在   DateEntry   中却没有，查看了源代码，原来是回调了用于更新标签和关闭的   selectDay   函数。这么作是很不负责任的，如果不修改源代码，我们就不得不在此控件旁添加一个按钮用于触发事件，这样一来不美观，而来更重要的是不符合一般的使用习惯。为此需要在   ConfigSpec   中添加一个   -btncommand   的标签，并在   selectDay   中回调。  

引入文件结构保护的原因

随着越来越多的工作、数据被迁移到服务器及存储上，对于这些作为业务基础的软硬件的安全性和可靠性，我们需要提高关注度，并在尽可能的范围内提高这种可靠性，以保障工作的平稳顺利开展。  

针 对不同的内容，我们可以采取不同的安全保障策略。比方说，对于服务器的灾难恢复，比较方便而合适的办法是用双机热备，备机通过监视主机运行状况，实现尽可 能快地恢复服务。而对于资料的存储，我们多是会选择一些实践证明了的比较可靠的数据备份和恢复方法，这些方法多是基于某种特定的数据库的，或者是数据库自 身提供的。  

以上两点内容是大多数管理者想得到并且可以做得不错的，我们常常会忽略一点是，作为提供某种服务的程序本身的安全性。打个比方说，提供   web   服务的   apache   ， 其配置和一些附属的文件可能遭到破坏，而且即便是有操作系统锁级的保护，进程也可能被恶意停止，进而破坏文件。拓展开来讲，任何以文件或者文件树形式存储 的数据的安全性，一向被忽略。其结果是，我们不得不重新安装服务并配置参数，这不是一项轻松的工作，尤其是对于一些复杂的程序而言。  

虽然针对不同服务的保护各不相同，但一般都需要涉及到对于该服务的文件结构保护，在此基础上在做一些进程的恢复工作等。  

文件结构保护系统的架构

除了必要的防杀毒软件之外，还需要一些更一般的保护手段，因为病毒库的更新总是有滞后性的。这些手段包括建立文件结构信息备份、实时监控和文件恢复等。  

首 先，在确定系统一切正常的前提下，对于需要进行保护的文件结构，我们需要采集能唯一标识该结构的必要信息，至少包括一个描述文件结构的数据结构和在其中每 一个文件的唯一标记。就前者而言，可以是一个多叉树或者向量，这个根据不同的工具的特性具体而定；文件唯一标记可以通过计算整个文件的   md5   码来得到，这也是现阶段在网络上发布文件尤其是大型文件时，保证文件完整性的一个通用做法，比如说   ubuntu   的发布。除了多叉树或向量数据结构需要驻留本地之外，其他的必要信息连同文件结构中所有有效文件将存储到一个可以保证安全的位置，这个位置一般是一台被隔离的服务器，通过有限的端口与存在受保护文件结构的服务器相连接，也就是监控端。  

完 成了文件结构的备份之后，将建立服务器之间的监控关系。因为文件遍历的本地性特点，所以主逻辑即数据结构与文件结构之间的比较需要在被监控段实现。根据比 较之后的结果，包括被恶意添加或删除的文件，做出是否恢复或删除的决定。而具体到每一个文件的完整性检测，则需要被监测端将当前次文件遍历中得到的   md5   码，发送至监测端进行比较。因此，从最终的实现来看，服务器两端之间的关系并不能完全用监控来描述，事实上被监控端将负责起遍历文件结构的工作，而监控端将主要负责   md5   码比较和文件恢复的功能。  

最后在监控端，通过一定的途径连接监控程序和备份信息，实现文件按顺序有效地回传，这样就基本上形成了一个文件结构保护系统的框架。  

需要注意的一些细节

文件结构信息的采集需要在系统建立之初就准备就绪，然后通过人工拷贝的方法移植到监控端。这个采集过程相对来说比较简单，只需要一次文件结构的遍历就可以实现。监控端的信息存储可以考虑使用数据库，而在存储文件的时候，根据具体的回传特点可以直接存储在文件系统之下或者以   blob   的形式存入数据库。  

相比于略显简单的初始化，保护系统实现的关键环节在于文件结构与数据结构的比较以及如何准确地回传文件。  

首 先数据结构的建立需要在保护系统启动的初始化环节完成，之后它将作为整个系统运行的基础，循环地将文件结构与它进行对比。而该对比过程可以通过两种方法来 实现。第一：两次遍历，即数据结构和文件结构遍历。这么做的好处是实现难度不大，尤其是在文件结构遍历部分，可以任意选择深度或广度遍历。但是针对遍历中 每个节点遇到的文件或文件夹，不得不查询一次数据结构，对于设计不佳的数据结构，这么做的结果可能又是一次遍历，这就增加了运行的时长。第二：一次遍历， 即在数据结构和文件结构同时以一种相对协调的步调向下遍历。这里所说的向下即是说，需要在完成本层次遍历的基础上才能继续下一个层次，也就是层次优先遍 历。这样的做法需要在设计上保证数据结构与文件结构具有类似性，而对于层次的控制也完全依靠人工逻辑完成，但在运行上将获得比前一种方法快一个数量级以上 的优势。  

在文件回传方面，由于存在很大可能性是需要恢复的一个文件列表，所以应准确控制其中每一个文件恢复的启动与截至。可以采用架设   ftp   服务器的方法，在传输单文件时阻塞本地剩余传输队列中的文件。在这里采用了这种模式，但未直接使用   ftp   ，而是采用了一种简化的模拟方式：被监控端维护一个文件处理队列，通过阻塞的方式和先进先出的顺序来处理   文件句柄   ；建立了两个   socket   连接，其中之一在监控端接受被监控端发出的指令并启动数据传输，另一个在被监控端接受来自监控端的文件传输完成信号并关闭本地文件句柄，然后通知启动下一个文件传输。  

Perl  实现的几点建议

一：   对于这种通过网络来连接的服务，整体的框架可以考虑使用   poe   ，这将极大地减少底层代码的维护量，而将精力主要集中到业务逻辑的实现上来。尤其是在合理利用   component   的情况下，一段几十行的   socket   代码可能会被压缩为短短几行。更为重要的是，   poe   在单线程内实现了多任务模式，虽然依旧会阻塞在长任务执行过程中，但这方便各个任务之间信息的传递和资源的共享。对于未来其他模块功能的增加，也   提供了   一个可扩展的基础。比如，需要为客户端提供一个可视的操作界面，只需引入   Tk   ，   poe   会在变量表中自动添加根元素   $poe_main_window   。  

二：   由于文件结构信息的量一般不是很大，因此在事先未安装其他数据库的情况下，信息的存储可以考虑使用轻量级的   sqlite   。它没有守护进程，一般以嵌入的形式   服务   于各个   任务   中。  

三：   体现文件结构逻辑的数据结构，可以使用   hash   表来实现，在这里   hash   表起得是多叉树的作用。打个比方，针对绝对路径  

d:\sources\perl\frs\md5_check.pl

其数据结构将是   :

$base->{d}->{sources}->{perl}->{frs}->{md5_check.pl} = ’f’

也就是说任意的目录是一个   hash   引用，而最终的文件节点是一个内容为“   f   ”的   text   变量。那么在遍历时，就可以通过   ref   节点类型来判断是目录还是文件。  

四：   在处理关闭文件传输的指令时，可以考虑使用   ikc   来远程调用本地指令，这实际上是简化了由远程发指令、本地翻译再到本地指令执行这一连串的过程，用在这里也方便未来丰富远程指令。  

原文在http://www.perlmonks.org/index.pl?node_id=170648里，代码抄了一遍。  

use Net::Pcap;  

use NetPacket::Ethernet;  

use NetPacket::IP;  

use NetPacket::TCP;  

use strict;  

my $err;  

#  Use network device passed in program argments or if no  

#  argument is passed, determine an appropriate network  

#  device fo packet sniffering using the  

#  Net::Pcap::lookupdev method  

my $dev = $ARGV[0];  

unless (defined $dev) {  

    my @devs = Net::Pcap::findalldevs(\$err);  

    if (defined $err) { die 'Unable to determine network device for monitoring - ', $err; }  

    if (length(@devs) == 2) { $dev = $devs[1]; }  

    else { $dev = $devs[0]; }  

    }  

#  Look up network address information about network  

#  device using Net::Pcap::lookupnet - This also acts as a  

#  check on bogus network device argument that may be  

#  passed to the progeam as an argument  

my ($adress, $netmask);  

if (Net::Pcap::lookupnet($dev, \$address, \$netmask, \$err)) {  

    die 'Unable to look up device information for ', $dev, ' - ', $err;  

    }  

#  Create packet capture object on device  

my $object;  

$object = Net::Pcap::open_live($dev, 1500, 0, 0, \$err);  

unless (defined $object) {  

    die 'Unable to create packet capture on device ', $dev, ' - ', $err;  

    }  

#  Compile and set packet filter for packet capture  

#  object - For the capture of TCP packes with the SYN  

#  header falg set directed at the external interface of  

#  the local host, the packet filter of '(dst ip) && (tcp[13] & 2 != 0)'  

#  is used where IP is the IP address of  

#  the external interface of the machine,  For  

#  illustrative purposes, the IP address of 127.0.0.1 is used in thsis example.  

my $filter;  

Net::Pcap::compile(  

    $object,  

    \$filter,  

    '(dst 127.0.0.1) && (tcp[13] & 2 != 0)',  

    0,  

    $netmask  

) && die "Unable to compile packet capture filter";  

Net::Pcap::setfilter($object, $filter) &&  

    die 'Unable to set packet capture filter';  

#  Set callback function and initialate packet capture loop  

Net::Pcap::loop($object, -1, \&syn_packets, '') ||  

    die 'Unable to perform packet capture';  

Net::Pcap::close($object);  

sub syn_packets {  

    my ($user_data, $header, $packet) = @_;  

    #  Strip ethernet encapsulation of captures packet  

    my $ether_data = NetPacket::Ethernet::strip($packet);  

    #  Decode contents of TCP/IP packet contained within  

    #  captured ethernet packet  

    my $ip = NetPacket::IP->decode($ether_data);  

    my $tcp = NetPacket::TCP->decode($ip->{'data'});  

    #  Print all out where its coming from and where its going to!  

    print  

        $ip->{'src_ip'}, ":", $tcp->{'src_port'}, " -> ",  

        $ip->{'dest_ip'}, ":", $tcp->{'dest_port'}, "\n";  

    }  

只有一行代码。如下：

for ('a'..'z') { chdir "$_:" && print "$_:\n"}

Tell me why
为什么要写这个有关轮子代码的解析呢？如果是用 IO::Socket配合select_read等写的代码，一来需要自己处理客户socket的连接，二来还要整理传入的数据，如此这般使得代码量变得 很巨大，对其解析可能会需要很大的工作量，事实上我也大致写过很长的一个。而且这种具有普遍意义的代码任放在哪个平台上其中的内容大多是不会发生变化的， 因而很多地方都可整合起来。在另一个极端上来说，如果使用像POE::Component::Server::TCP的组件，虽然可以将代码量控制在一个 很小的范围，但是同时也隐藏了绝大多数的细节，对于刚刚接触POE的初学者，这无异于一个神奇的盒子。所以要用夹在中间的轮子代码，先有一个大致的概念， 之后再去深究其中的细节。

一拖n的结构
还是老样子，先把代码的大致结构讲一下。和大多数底层的POE程序差不多，一个session拖一屁股事件句柄。

POE :: Session -> create(
    inline_states  =>  {
        _start  =>   \& server_start ,
        server_accepted  =>   \& server_accepted ,
        client_input  =>   \& client_input ,
        client_error  =>   \& client_error ,
        server_error  =>   \& server_error ,
});

_start 事件建立了一个服务socket，再用ListenAccept轮子监听它。当发现有客户socket连接时，触发了server_accept事件。在 该事件中，我们使用ReadWrite轮子来监视客户输入，并将其返回给客户。如果发生意外，根据事故的制造者，分别交予client_error或者 server_error处理。其中server_error将销毁ListenAccept轮子，从而停止整个程序。
所以，不一样关键在于有了ListenAccept和ReadWrite两个轮子。前者用来监听客户socket连接，后者用来处理传入的数据并将它发送回去。这在很大程度上节约了代码量，使我们可以集中更多的注意力在业务逻辑上，而又不至于对于其中的具体实现一头雾水。

记忆点
对 于这两个轮子，需要牢记的有两点，首先是参数。ListenAccept需要至少三个，分别是Handle、AcceptEvent和 ErrorEvent。Handle是监视对象，AcceptEvent是接受连接时触发的事件，到处可见的ErrorEvent则用来处理错误。这三个 缺一不可，不然运行会发生错误，至少需要写一个空句柄。ReadWrite也差不多，只是InputEevnt代替了Listenaccept中的 AcceptEvent，用来处理客户输入。
第二点要注意的是ARG参数。可以这么认为，ARG0是与轮子具体功能相关的, ARG1则代表了轮子本身的ID。打个比方，因为ListenAccept是用来监听并接受客户连接的，那么ARG0就是被接受了的客户。由于对于轮子的 使用经常是跨事件的，所以必须保留对于轮子的引用。ID因其唯一性，所以可以在哈希表中作为键值以保存对轮子的引用。

测试

#!/usr/bin/perl
use warnings;
use strict;
use POSIX;
use IO :: Socket;
my $sock = IO::Socket::INET->new(
    PeerHost => '127.0.0.1',
    PeerPort => 12345,
    ) or die "can't connect to server: $@\n";
my $word = "hello.\nmy name is Jinhao.\nwlecome to POE. a \n";
$sock->send($word);
$buffer = '';
$sock->recv($buffer, POSIX::BUFSIZ);
print $buffer unless $buffer eq '';
$sock->shutdown(0);

客 户端还是在本地，应用了一个IO::Socket来发送一段带“\n”的数据，之后接受返回并打印结果。可以印证一点，ReadWrite轮子只有在发现 换行才起作用，也就是说如果发送的数据的最后不是以“\n”结尾的，那么打印结果会少一段。至于为什么没有发现数据结尾，我想可能跟操作系统有关系。

Perl-Tk 在windows下的表现着实让我头疼了很长一段时间，最无法忍受的一点是缺乏稳定的线程支持。比如，无法在一个界面上一边录制新闻，一边完成下一个录制时间的设定，整个程序被阻塞在那儿无法动弹。某些情况下可以使用非阻塞的本地socket来实现进程间的通信，但这么做很费劲，而且使得程序像一个奇怪的网络服务器。POE作为在单进程中实现并行的框架，提供了对Tk的支持，很好地解决了组件间通信的问题。

大致的介绍

很容易可以看出来一个不一样的地方，比如说用$poe_kernel代替了一贯的POE::Kernel，但在实际运行中会发现$poe_kernel是对POE:;Kernel的引用，最终起作用的依然是POE::Kernel。好了，除了这一点外，其他还是与传统的POE程序差不多。

首先建立了一个包含了内置_start和两个自定义（ev_count，ev_clear）事件的session。之后在_start事件中，在已初始化了的$poe_main_window上建立一个内容为“Counter”的标签，内容为变量$_[HEAP]->{count}的标签和一个用来清零的按钮。至于ev_count和ev_clear事件不过是自增和清零$_[HEAP]->{count}而已，其中ev_count事件会递归回调自身以实现不断自增的过程。

如果一切顺利，运行之后的结果如下图所示：

单击Clear按钮，中间的数字将从零开始继续飞速自增。如果想让它自增得慢一点，或者说可以看得清，可以在ev_count事件中delay自身回调一小段时间。需要注意的一点是不要指望用sleep，因为它会让整个POE崩溃。

一些细节

下面来讲一下隐藏在这一切背后的一些小细节。事实上，这些细节危险重重，任何细小的错误哪怕是位置的改变都可能导致程序的失败，而原文中的某些注释也比较晦涩或者是存在误导，需要详细说明一下。

$poe_main_window 在strict环境中出现，这让我很吃惊。一般情况下，这样的非my变量是无法通过检测的。唯一的解释是use POE在背后干了很多事情，多得连POE::Kernel都增加了叫一个$poe_kernel的引用，当然这是为了保证POE::Kernel不被自动垃圾回收。在这里不得不说的是，use Tk必须出现在use POE之前，否则use POE不会初始化生成$poe_main_window。所以可以这么认为，use POE会通过检测其之前的模块调用来决定之后的框架行为，这点在其他模块的应用中不是很多见，至少在我是第一次看见。

原文中有这么一句话“Widgets we need to work with later, such as the counter display,must be stored somewhere.The heap is a convenient place for them.”意思是说“要在之后用到的组件，比如说显示自增计数的标签，必须存储在某个地方，而堆栈就是一个方便的场所。”这也让我感到很困惑，至少在这个例子中，之后没有显式地用到这个计数显示标签。如果非要说用到，那么就是ev_count事件中的$_[HEAP]->{counter}以textvariable的身份影响到其宿主，但事实上这非常隐晦，而且为此保存一个引用似乎也毫无意义。后来的实验证明了我的猜测，在注释掉这个引用之后程序依然可以正常运行，也就是说原文这句话并非针对于本例子或者说毫不相干，其中的“such as”极易引人误入歧途。它真正想说的是，为了可以在某个事件中改变组件的行为，需要一个全局可见的引用，而$_[HEAP]正是恰当的选择，其实用一个全局哈希表就可以得到相同的效果，只是这么多就显得多余了。

最后的一点是有关于POE本身的机制。在ev_count中为了实现不断自增，在其事件处理句柄中有一句自身回调，而在ev_clear中仅仅是将计数清零了而已。一开始我有些担心自增行为会中断，因此在ev_clear中增加了一句触发ev_count事件的命令，但这么做是多余的。首先POE中的每一个事件句柄都是并行的，因此ev_clear不会中断ev_count的行为；第二，作为两个事件之间关联的全局变量$_[HEAP]->{counter},POE为其提供了锁保护，不必担心其中一个事件的行为导致另外一个崩溃。

几句话

因为不是正儿八经地写论文，所以遣词造句就显得随性了一些。倒不是说我可以不认真了，相反地，对于一些细节倒是表现得更自然。

这个例子非常简单，简单得几乎没有实用价值，但是说明了问题。我认为一个好的tutorial就应该这样，简单而能说明问题。简单就是说容易让人看懂，说明问题则是把注意事项讲清楚了，之后全凭各人兴趣和悟性了。POE Cookbook是一本非官方的技术文集，没有出版物，甚至说如果你写了一个好的例子，也可以被收录其中。但是每个例子都很通俗易懂，从最简单的入手，由浅入深，最后形成一个系统。反观国内的一些技术出版物，往往枯燥理论先讲一大堆，吓跑一批人；再举一两个可以堪称作者代表作的复杂例子，又闷掉一批人，结果是弄得是曲高和寡。

1 ：升级方案建立的起因
    目前的内部文件阅读服务器由于使用年代较长，经常出现无响应甚至死机的状况。由于内部文件阅读服务器是我台员工了解并获取规章制度内容和近期活动消息的一个重要途径，所以该服务器的稳定性显得十分重要。就目前的管理情况而言，除了定期的检查之外，一般都是通过阅读者的通报获知服务器处于无响应的状况，很难做到及时发现并处理。
    单纯通过增加检查次数的方法很难收到理想的效果。一来即便达到一天十次检查的量，对于服务器而言仍然是小时单位的数量级，而且只能在工作时间内施行；再者，由于没有配套的同步备份方案，即便发现服务器崩溃，恢复重建所消耗的时间依然相当可观。长时间停机导致信息传达的滞后将直接影响到工作的开展，试想如果这种情况发生在关键性服务器如新闻文稿系统上的话，将造成不可估量的严重后果。  

2 ：网络双机热备的思路
    所要采用的采用双机热备的办法，双机热备即是目前通常所说的 active/standby 方式。当 active 服务器出现故障的时候，通过软件诊测（一般是通过心跳诊断）将 standby 机器激活，保证应用在短时间内完全恢复正常使用。数据同步的方案一般在设计双机热备服务器时制定，比方说使用共享存储器就是个简单方便的解决办法；更加有效的方法的是在编写配置与数据输入输出相关的服务程序，使数据同时写入主备服务器中相关的数据库。但是在本文的例子中，由于文件服务器在建立时是一个单机的形式，所以其中的程序和数据都是针对单机进行设置的，如果要实现传统意义上双机热备的数据同步，需要对原先的网站程序和存储方案做较大的的修改，除开 standby 服务器的费用外，可能还需要另外购买存储设备。在对源文件无法进行修改或者预算有限的情况下，这种代价的方案并不是完全适用。
    为了克服以上的几个局限，我们利用网络代替传统心跳线和传输数据来同步数据，不但利用了现有的网络资源来节省投入的成本，而且在必要的情况下通过建立在不同端口的监听， standby 服务器甚至可以同时为多台提供不同服务的 active 服务器的备用支持。
    首先， standby 服务器中配置监控脚本，通过循环心跳检测 active 服务器的生存状况，达到实时监控的目的，一旦发现出错状况就可以采取预先设置的方案及时接管 active 服务器服务。通常情况下，一旦服务器崩溃，其网络功能也将停止，所以可以简单采用 ping 的方法监测 active 服务器；但是更一般的情况是，服务器仅仅是停止了某一项服务，比如网站发布服务或者数据库服务，而其网络联通性依然良好，针对这种情况需要在主备双方配置监测特定服务的信息问答脚本。比方说， active 服务器提供数据库查询服务，在每次接受到来自备服务器的心跳包后， active 服务器执行一次特定的 sql 查询并将查询所得与预期的比对，得到的结果以布尔值的形式传回备服务器，最后由备服务器决定是否接管服务。
    接着，为了保持 active 服务器与 standby 服务器中数据的一致性，需要将 active 服务器上的文件或数据库的更新内容，定期地通过一定的途径同步到备服务器中。对于数据处理不是很频繁的服务器，可以采用定期备份的方式。如需要采取更加细致的做法的话，在被服务器定期备份的基础上， active 服务器可以配置数据更新检测脚本，一旦检测到有数据更新就将其写入同步数据包中，当数据包达到规定大小之后就可用它来同步 standby 服务器。同步数据包大小的设置视乎网络的通畅度和服务器的响应能力而定。在两个条件都较好的情况下，可以采用小数据包的形式，这样做的好处在于主备的同步度较高， standby 服务器在接管服务时可以最大限度再现 active 服务器内容。而在有任何一个条件或者两者都不理想的情况下，需要适当增加数据包的大小。另外，由于目前一些大型的数据库普遍支持触发器，在同步这类数据库时我们可以利用触发器来保存添加、删除和更新的记录操作，很大程度上简化了同步的过程。  

3 ：具体的升级方案和主要脚本分析
3.1 ：心跳监视
    现在将以上的思路与具体的情况想结合，实现文稿阅读服务器升级至双机热备。由于该服务器提供的是 http 的网页浏览服务，所以在 standby 服务器中只需要配置定期具备获取网页功能的脚本即可以达到判断 active 服务器服务是否正常，换一句换说在做这个特例中 active 服务器的心跳应答是建立在已有的 http 服务上的，无需再建立额外的监听端口。
    以下是备份服务器上的心跳脚本 heartbeat.bat ，心跳间隔为一个小时即 3600 秒， active 服务器域名是 file.zsgd.com ， standby 服务器为 file-bak.zsgd.com 。 脚本首先建立了一个无穷循环，在该循环中每隔一个小时使用 LWP::Simple[1] 下载一次阅文站首页的内容，如果下载失败则表示 active 服务器 http 服务失效， standby 服务器将调用 iisweb.vbs[2] 来启动本身的 iis 网站服务。然后用 Net::FTP[3] 登录 zsgd.com 主站的 ftp 下载默认页面文件 default.asp ，修改其中的阅文站链接，使其指向 standby 服务器。最后将修改完的 default.asp 上传至 zsgd.com 主站 ftp ，覆盖原先的文件。

heatbeat.bat

3.2 ：数据同步
    在数据同步方面， msdn 上有关于基于 Microsoft Jet 数据库引擎的 internet 数据库同步的具体方案 [4] ，为 windows 平台上大型数据库的同步提供了良好的途径。但是这次升级的服务器中配置的是小型 access 数据库，而且数据上载周期较长，没有 频繁的删除或者更新数据项的操作。所以出于实验和学习的目的，这里通过配置脚本来实现 internet 中 access 数据库的监视与同步。
    在 active 服务器中配置 datamonitor.bat 脚本监视数据库的更新情况。首先读入参数文件中的数据，该参数文件保存的是前一次脚本运行得到的 access 数据库文件的最后修改时间和其中各个表的数据项 id 值，通过比对本次脚本运行得到的数据库修改时间与最后一次修改时间即可判断数据库在两次脚本运行期间是否更新了数据。一旦发现有更新，脚本将使用 DBD::ADO 连接 access 数据库。首先，检测各个表中 id 值大于前次查询最大 id 的数据记录，这些就是新插入的数据项；再在小于最大 id 值的 id 中检索不重复项，这些是被删除的数据项；接着用本次查询所得的 id 值替换参数文件中的内容；然后将这些数据分类打包，发送给 standby 服务器的数据同步监听脚本；最后做一些必要清理和初始化工作，一个小时后进入下一个周期重复以上的步骤。
    这么做的一个缺点是很难检测更新数据项，虽然理论上可以通过在表中设置更新标记的方法提示数据更新，但是更新标记的修改程序必须嵌入网站程序，这在加密的网页程序中将很难实现，退一步讲如果服务是基于编译了的程序的话，这样的修改将无从谈起。所以从某种程度上表明，重要的数据服务不要建立在文本型的数据库上，对于有同步要求的服务，选择的数据库至少要支持触发过程。在资金允许的前提下，最好使用如 oracle 、 db2 等大型的数据库系统，另外免费的 mysql 和 postgresql 也是不错的选择。

tbl-pic-monitor.bat
    在 standby 服务器中配置监听服务脚本用以检查并接受来自 active 服务器更新数据包，接着将接收到的数据中的前缀指示判断该数据是用于插入或是删除，从而再运行下一步的数据库更新操作，最后脚本进入下一个周期的等待监听。

tbl-pic-recv.bat 

4 ：建立跟踪系统运行的系统日志
    一个成功服务器解决方案的产生，需要后期长时间的跟踪和调试。在建立了基于网络的双机热备系统之后，为了方便了解和检查 active 和 standby 服务器中各个脚本的执行情况，需要对脚本做一些修改，使其能将执行的结果输出并存储到特定的日志文件中，方便管理员通过查询其中的内容来判断系统运行的状况。对于严重的状况，比如 active 服务器 down 机，系统还可以通过发送 email 的方式通知管理员，使其能及时做出反应。
    在心跳监测脚本中，当每个周期运行结束后，向日志文件里记录本周期检测启动成功与否、启动或失效的日期时间和检测得到的 http 反馈内容，如果没有得到内容则发送 email 给指定的管理员。对于数据同步， active 服务器中的脚本将记录本周期同步启动日期时间、数据库文件的最后一次修改时间、数据库连接状况、 socket 客户端启动成功与否及数据发送的结果； standby 服务器中的脚本将记录收到更新数据的时间和所有的数据内容以便于在必要的时候恢复数据库。

参考文献：

[1] perldoc5.8.8 www.perl.org 2006

单位有三百多人，作为网管每天要接到很多电话，有很多一时无法想起对应的名字，翻查通讯录不仅速度慢而且容易漏过。为了方便起见，在 sqlite 上建立了一个通讯录数据表，然后用 perl 编写了一个查询脚本。效果不错的同时，也有同事希望可以得到一份拷贝。但是这时遇到一个问题，如何保证通讯录在不同人手中保持版本的统一性。最好的办法是建立一个服务 / 客户端的模式，在本机上维护一个数据库，而其它人通过连接数据库得到相关的查询结果。

具体的解决方法是这样的：在本机上维护一个到 sqlite 数据库的连接并建立一个来自于客户端的 socket 的监听，接受远程查询条件并回复查询结果；客户端志负责发送和接受这些最简单的任务。

客户端的代码：

       服务器端的代码：

Perl 中对程序中的语句是按 utf8 的编码处理的，对英文没有什么影响，但是中文就有一些麻烦。

比方说，在 notepad 中默认是以 gb2312 的编码处理中文。如果在其中编写带有中文的 perl 程序，一般都难令人如意。这种情况下，一般会拜托 encode 模块，它是天然集成在 activeperl5.8.8 中的，如果没有找到可在 ppm 中 search 一下。

通常只要用到一下两个函数即可：

l           encode(‘ 编码 ’, ‘ 文字 ’)

l           decode(‘ 编码 ’, 数据 )

其中 decode 是将其中编码形式的文字转换为 utf8 数据；而 encode 则是将以 utf8 编码的数据转换为编码形式的文字。举一个例子：

$str = decode(‘gb2312’, ‘ 你好 ’);

Print encode(‘gb2312’, $str);

以上是可以正确打印出“你好”二字的。首先是告诉 perl “你好”是一个 gb2312 编码的文字， perl 把它以 utf8 的形式存在 $str 中；在将 $str 以 gb2312 的形式转换为文字并打印出来。

再说一下数据库。数据库都有自己的编码方式，比如说 utf8 、 eu_cn 、 gbk 等等。一定编码方式的数据库只能接受相应编码的数据，一般从兼容性上考虑会使用 utf8 编码的数据库。

在 postgres8.1 中，向一定编码的数据库中输入数据时，可以用 \encoding 将 client encode 设为与输入数据相同的形式。比方说在 psql 中向 utf8 编码的数据库插入 gbk 编码的汉字，就可以：

\encoding ‘gbk’

不然只会得到一个无法输入的提示。遗憾的是， perl 里没有像 \encoding 这样的命令，于是又要拜托 encode 模块了。

#------------------------------------

use DBI;

use Encode;

use strict;

#连接数据库
my $dbh = DBI->connect("dbi:PgPP:dbname= 数据库名 :host= 服务器地址 :port= 服务器端口 ", 登录名 , 登录密码 ,{PrintError => 0})

or die $DBI::errstr;

#准备sql语句 

my $inr = $dbh->prepare("insert into name values('encode('utf8', decode('gb2312',' 你好 '))')")

or die $DBI::errstr;

#执行sql语句 

$inr->execute() or die $DBI::errstr;

#打印成功信号 

print "WELL DONE!";

#---------------------------------------

    ruby -e "comman line"

    打多了后甚感麻烦，难道就不能象python的IDEL？事实上是有一个fxri的，就是太难看了。偶不要边上的大堆注解，如果它做得象python的自省那也算了，而且慢得要死。索性自己写一个好了，要求能运行单行的程序就行，但发现ruby支持多“-e”输入，所以就把多行也一起支持了。

    程序是用perl写的，30几行而已。

use strict;

print "RubySgl=>";
my $cmdline="";
my $rsign="ruby";
my $esign=" -e";
my $sptr=" ' ";
my $sgl=<STDIN>;
chomp($sgl);

while(!($sgl eq "\\q")){

   if($sgl eq "\\h"){
      print "> > > > >execute ruby single line programme\n";
   }#endif
   else{
      $cmdline=$rsign;
      do{
         $cmdline=$cmdline.$esign.$sptr.$sgl.$sptr;
         print "       =>";
         $sgl=<STDIN>;
         chomp($sgl);
      }while(!($sgl eq "\\e"));

      open(FOO,"-|",$cmdline);
      while(<FOO>){
         print "> > > > >";
         chomp();
         print $_."\n";
      }#endwhile
      close(FOO);
   }#endelse

   print "RubySgl=>";
   $sgl=<STDIN>;
   chomp($sgl);
}

    然后再建立一个rubysgl.bat文件来启动：

    @echo off
    perl d:\rubysgl.pl

    试运行，正常，8-->


redited at 2006-08-25

   做了一些细小的改进，增加了行号提示和清除所有输入的功能。本来还做了几个自省函数和清除特定行的功能，但程序变得巨大无比，自己都看不下去了，实在有违初衷，因此弃用。

use strict;

my $idx=1;
print "RubySgl<".$idx.">";
my $cmdline="";
my $rsign="ruby ";
my $esign="-e";
my $sptr=" ' ";
my $sgl=<STDIN>;
chomp($sgl);

while(!($sgl eq "\\q")){
 if($sgl eq "\\h"){
  print " > > > > >Execute ruby single line programme.\n"; #Display IDE informatrion
 }#endif
 else{
  $cmdline=$rsign;
  do{
   if($sgl =~ /^\\c\s*$/){
    $cmdline=$rsign;
    print " > > > > >LINES ALL CLAERED!\n"; #Clear former inputings
    $idx=1;
   }  
   else{
    $cmdline=$cmdline.$esign.$sptr.$sgl.$sptr;
    $idx++;
   }#endelse

   #continue to input
   print "       <".$idx.">";
   $sgl=<STDIN>;
   chomp($sgl);
  }while(!($sgl eq "\\e") and !($sgl eq "\\q"));

  if($sgl eq "\\e"){
   open(FOO,"-|",$cmdline);
   while(<FOO>){
    print " > > > > >"; #Display outputings
    chomp();
    print $_."\n";
   }#endwhile
   close(FOO);
  }#endif
  elsif($sgl eq "\\q"){ exit; }
  else{;}

 }#endelse
 
 print "----------another programme----------\n";
 $idx=1;
 print "RubySgl<".$idx.">"; #Restart programming
 $sgl=<STDIN>;
 chomp($sgl);
}


redited at 2006-08-26

修订了几个bug，程序改伟如下：
use strict;

my $idx=1;
print "RubySgl<".$idx.">";
my $cmdline="";
my $rsign="ruby ";
my $esign="-e";
my $sptr=" ' ";
my $sgl=<STDIN>;
chomp($sgl);

while(!($sgl eq "\\q")){
 if($sgl eq "\\h"){
  print " > > > > >Execute ruby single line program.\n";
 }
 else{
  $cmdline=$rsign;
  while(!($sgl eq "\\e") and !($sgl eq "\\q")){
   if($sgl =~ /^\\c\s*$/){
    $cmdline=$rsign;
    print " > > > > >LINES ALL CLEARED!\n";
    $idx=1;
   }  
   else{
    $cmdline=$cmdline.$esign.$sptr.$sgl.$sptr;
    $idx++;
   }

   print "       <".$idx.">";
   $sgl=<STDIN>;
   chomp($sgl);
  }

  if($sgl eq "\\e"){
   if($idx==1){ goto RESTART; }
   else{
    open(FOO,"-|",$cmdline);
    while(<FOO>){
     print " > > > > >";
     chomp();
     print $_."\n";
    }
    close(FOO);
   }
  }
  elsif($sgl eq "\\q"){ exit; }
  else{;}

 }#endelse

 RESTART:
 print "-----------another program-----------\n";
 $idx=1;
 print "RubySgl<".$idx.">";
 $sgl=<STDIN>;
 chomp($sgl);
}

my $seed=<STDIN>;
$seed**=3;
my @stack=();
open(NKCS,'>c:/code/nkcs.txt');

for(my $init=1; $init<=$seed; $init+=2){
   my $sum=$init;
   my $temp=$init;
   while($sum<$seed){
      push(@stack,$temp);
      $temp+=2;
      $sum+=$temp;
   }
   if($sum==$seed){
      while(@stack){print NKCS shift(@stack)."\n" ;}
      close NKCS;
      exit;
   }
   undef @stack;
}

close NKCS;
die("nkcs failed");

sub new{
 shift();
 my $val=undef;
 my $ref=undef;
 ($val,$ref)=@_;
 my $new_string={
  val => $val,
  ref => $ref
  };
 bless $new_string, data_string;
 return $new_string;
}

#return a reference to the hash holding two incoming parameters which are value of the node and a #reference to a next node

sub val{
 return shift()->{val};
}

#return the value of the node

sub ref{
 return shift()->{ref};
}

#return a reference to the following node

sub setval{
 my $tnode=shift();
 if(@_){
  my $tval=shift();
  $tnode->{val}=$tval;
  return 1;
 }
 return 0;
}

#set the node with a new value

sub setref{
 my $tnode=shift();
 my $tref=shift();
 if(CORE::ref($tnode)){
  $tnode->{ref}=$tref;
  return 1;
 }
 return 0;
}

#set the node with a new reference

sub setnull{
 undef %{shift()};
 return 1;
}

#undefine the node

sub length{
 my $count=0;
 my $head=shift();
 while( defined($head) ){ $count++; $head=$head->ref;}
 return $count;
}

#return the length of a list whose head is the current node

sub insert{
 my $head=shift();
 my $pos=undef;
 my $str=undef;
 if(@_==2){
  ($pos, $str)=@_;
  if($pos>=$head->length && $pos<0)
   {return 0;}
  else
   {
   my $pre=$head;
   my $cur=$pre->ref;
   my $index=0;
   while($index!=$pos && defined($cur)){
     $pre=$cur;
     $cur=$cur->ref;
     $index++;
   }#while
   $pre->setref(data_string->new($str, $cur)); 
   return 1;
   }#else
 }
 return 0;
}

#insert the current node leading list a new node taking the incoming parameter as the value

sub delete{
 if($_[1]==0){
  if($_[0]->length==1){shift()->setnull; return 1;}
  else{
   my $fir=shift;
   my $sec=$fir->ref;
   $fir->setval($sec->val);
   $fir->setref($sec->ref);
   $sec->setnull;
   return 1;
  }
 }
 my $head=shift();
 if(@_){
  my $pos=shift();
  if($pos>=$head->length && $pos<=0)
   {return 0;}#if
  else{
   my $pre=$head;
   my $cur=$pre->ref;
   my $index=1;
   while($index<$pos){
    $pre=$cur;
    if(defined($cur)){$cur=$cur->ref;}
    $index++; 
   }#while
   $pre->setref($cur->ref);
   $cur->setnull;
   return 1;
  }#else
 }#if
 return 0;
}

#delete the current node leading list a node whose position is related to the incoming parameter

1;

#写了个测试程序：

use data_string;

$temp=undef;
$node=data_string->new(1, $temp);

foreach (qw(2 3 4 5)){
 $ind=$_-2;
 if($ind<$node->length){
  $node->insert($ind, $_);
 }
}

$node->delete(3);

$temp=$node;

while(defined($temp)){
 print($temp->val."\n");
 $temp=$temp->ref;
}