perl原创精华文章！

deathcult

欢迎朋友们提供自己的原创文章，

请不要回复非原创文章的帖子，

谢谢你喜欢并支持perl版 ：）     

十分感谢各位作者：  

deathcult

[1] Blowfish模块
作者：hoowa


总在这里问东西也不能不给这里的朋友点东西
这是我刚刚做的，给你资料你整理一下就可以用了：）

Blowfish是一个强壮的可变长度由8个字节到56个字节(448位钥匙)的加密技术。
只有在双方持有相同的钥匙情况下才有可能解密数据。
他照比DES算发具有更高的安全性(目前无法破解)。
而且他的加密速度是最快的！
这里不讲他如何做的算法。我们只讲Crypt::Blowfish如何使用。

安装：
win32系统：
输入ppm命令，然后输入install Crypt::Blowfish回车等待安装结束，或search blowfish查看列表。

Linux下请到www.cpan.org下载模块，编译安装需要gcc

此模块是使用的最小8字节长度，最大56字节长度，在编写钥匙的时候如果不符合这个范围那么就将出现错误。
在加密的时候，需要将所加密的字符穿分割成为多个8字节长度的字符串，如果不够8字节可以填充空格等特殊字符。

以下是举例：

1. 
   
2. #!/usr/bin/perl
   
3. use Crypt::blowfish; #加载模块
   
4. 
   
5. 
   
6. #需要加密的资料
   
7. $data = qq~欢迎光临www.ilcatperl.org这里是Perl的天堂
   
8. 欢迎喜欢Perl
   
9. 如果你觉得Perl不行，那就是你水平太臭,回家看孩子玩吧~;
   
10. 
    
11. #构造对象
    
12. my $fish = new Crypt::Blowfish 'this is my key'; # 8 bytes < Key >; 56 bytes
    
13. 
    
14. #编码
    
15. @data = &block($data); #将数据以8个字节块化，如果最后不够补充空格
    
16. 
    
17. foreach (@data) {
    
18.         $encode .= $fish->;encrypt($_);
    
19. }
    
20. 
    
21. #解码
    
22. @data = &block($encode); #将数据以8个字节块化，如果最后不够补充空格
    
23. 
    
24. foreach (@data) {
    
25.         $decode .= $fish->;decrypt($_);
    
26. }
    
27. 
    
28. 
    
29. #块化子程序
    
30. sub block
    
31. {
    
32.         my ($string) = @_;
    
33.         my (@blocks,$last_length,$nu,$ad);
    
34.         my @blocks = unpack("a8 "x(int(length($data)/) . "a*", $string);
    
35. 
    
36.         $last_length = length($blocks[$#blocks]);
    
37. 
    
38.         if (($nu = 8 - $last_length) >; 0) {
    
39.                 for (my $i=1;$i<=$nu ;$i++) {
    
40.                         $ad .= ' ';
    
41.                 }
    
42.         }
    
43.         $blocks[$#blocks]= $blocks[$#blocks].$ad;
    
44.        
    
45.         return(@blocks);
    
46. }
    
47. 
    
48. #以上代码encode是编码后decode是解码后
    
49. #coding by hoowa
    

复制代码

deathcult

[2] 父进程与子进程communicate..利用PIPE的例子
作者：apile


# 本程序主要利用PIPE来建立Parent Process与Child Process间的互相连通，
# 利用%STATUS纪录目前Child Process的所有状态，与%CHILDREN纪录所有的Child
# Process。
# Parent Process：负责由CHILD_READ中读取所有CHILD　Process的输入，并纪录
# 这些Process目前的状态。当收到INT、HUP、TERM等Signal时，即跳出主要loop
# 并将所有child Process全部杀光...

1. 
   
2. #!/usr/bin/perl
   
3. use strict;
   
4. use IO::Select;
   
5. use POSIX qw(WNOHANG);
   
6. 
   
7. #---Define constants：定义准备先fork几个Process
   
8. use constant PREFORK_CHILDREN   =>; 3;
   
9. # debugging information：显示过程
   
10. use constant DEBUG              =>; 1;
    
11. 
    
12. # declare globals
    
13. my $DONE=0;             # set flag to true when server done
    
14. my %STATUS = ();        #child status information, child pid form keys of the ha
    
15. sh, status form the values
    
16. #--- 纪录所有Child Process的id...
    
17. my %CHILDREN = ();
    
18. #---Interrupt handles,跳出loop
    
19. $SIG{TERM} = $SIG{INT}=$SIG{HUP} = sub { $DONE++ };
    
20. #--- get CHLD Signal
    
21. $SIG{CHLD} = sub {
    
22.          while((my $child=waitpid(-1,WNOHANG)) >; 0){
    
23.            delete $CHILDREN{$child};
    
24.          }
    
25.       };
    
26. # create a pipe for IPC：建立PIPE
    
27. pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n";
    
28. my $IN = IO::Select->;new(\*CHILD_READ);
    
29. # prefork some children
    
30. make_new_child() for (1..PREFORK_CHILDREN);
    
31. 
    
32. # main loop
    
33. while(!$DONE){
    
34.   # avoid parent block in the I/O call
    
35.   if ($IN->;can_read){ # got a message from one of the children
    
36.     my $message;
    
37.     next unless sysread(CHILD_READ,$message,4096);
    
38.   # may contain several messages
    
39.     my @messages = split "\n",$message;
    
40.   # retrive every pid and status code
    
41.     foreach (@messages){
    
42.       next unless my ($pid,$status) = /^(\d+) (.+)$/;
    
43.   # change status
    
44.       if($status ne "done"){
    
45.          $STATUS{$pid} = $status;
    
46.       }else{
    
47.   # delete pid
    
48.          delete $STATUS{$pid};
    
49.       }
    
50.     }
    
51.   }
    
52. 
    
53.   warn join(' ',map {"$_=>;$STATUS{$_}"} keys %STATUS),"\n" if DEBUG;
    
54.   last unless %CHILDREN
    
55. }
    
56. warn "Termination received, killing children\n" if DEBUG;
    
57. #-------------杀掉所有Child Process
    
58. kill TERM =>; keys %CHILDREN;
    
59. sleep while %CHILDREN;
    
60. 
    
61. warn "Normal termination.\n";
    
62. exit 0;
    
63. #---- 建立新的Process
    
64. sub make_new_child{
    
65.   die "can't fork :$!" unless(defined( my $child = fork()));
    
66.   if($child){   # child >; 0, so we're the parent
    
67.     $CHILDREN{$child} = 1;
    
68.     warn "launching child $child\n" if DEBUG;
    
69.   }else{
    
70.     close CHILD_READ;   # no need to read from pipe
    
71.     do_child();         # child handles incoming connections
    
72.     exit 0;             # child is done
    
73.   }
    
74. }
    
75. #------ child process
    
76. sub do_child{
    
77.    # write status code: idle
    
78.    syswrite CHILD_WRITE,"$$ idle\n";
    
79.    for(1..1000000){ };
    
80.    syswrite CHILD_WRITE,"$$ busy\n";
    
81.    for(1..1000000){ };
    
82.    syswrite CHILD_WRITE,"$$ done\n";
    
83. }
    
84. 
    

复制代码

deathcult

[3] 父进程与子进程communicate..利用IPC::Shareable的例子
作者：apile

Hi...這是昨天那個例子改用share memory的方式，兩相比較..我覺得
PIPE比較好點...尤其是有大量資料需要互傳的時候...
---------------------------------------------------------------------------------
本程序主要使用IPC::Shareable module来建立一块共同的share memory
以为所有程序所用，主要利用tie将%STATUS、%status与IPC::Shareable
tie在一起，其中SHM_GLUE用来向OS做注册一块memory的識別符號，因
此若程序失败， 未能正常清除share memory，必须利用OS提供的share
memory工具清除， 否则程序将无法启动。linux可以使用ipcrm清除
Parent Process利用sleep()，不做任何动作，而child Process的状态，
透过kill -ALARM getppid() 通知Parent，child Process的status已经
改变了..
-----------------------------------------------------------------------

1. 
   
2. #!/usr/bin/perl -w
   
3. # p_shm.pl
   
4. 
   
5. #---- 加载 module包含IPC::Shareable
   
6. use strict;
   
7. use POSIX qw(WNOHANG);
   
8. use IPC::Shareable;
   
9. 
   
10. #---- 定义常数
    
11. use constant PREFORK_CHILDREN =>; 3;
    
12. #--- 定义识别文字
    
13. use constant SHM_GLUE =>; 'PERF';
    
14. #--- 查测过程
    
15. use constant DEBUG =>; 1;
    
16. 
    
17. #--- 宣告全域变量
    
18. my $DONE = 0; # set flag to true when server done
    
19. #--- 纪录CHILD的STATUS
    
20. my %STATUS = ();
    
21. my %CHILDREN=();
    
22. 
    
23. #--- 抓取Signal INT,TERM,ALRM----
    
24. $SIG{INT} = $SIG{TERM}= sub{ $DONE++ };
    
25. $SIG{ALRM} = sub {}; # receive alarm clock signals, but do nothing
    
26. #----抓取 signal : CHLD
    
27. $SIG{CHLD} = sub {
    
28. while((my $child=waitpid(-1,WNOHANG)) >; 0){
    
29. delete $CHILDREN{$child};
    
30. }
    
31. };
    
32. 
    
33. # create a shared memory segment for child status
    
34. tie(%STATUS,'IPC::Shareable',SHM_GLUE,
    
35. { create =>;1,exclusive=>;1,destroy=>;1,mode=>;0600})
    
36. or die "Can't tie \%STATUS to shared memory: $!";
    
37. 
    
38. # prefork some children
    
39. make_new_child() for(1..PREFORK_CHILDREN); # prefork children
    
40. 
    
41. #-- Main loop
    
42. while(!$DONE){
    
43. sleep; # sleep until a signal arrives(alarm clock or child)
    
44. # get the list of idle children
    
45. warn join(' ',map{"$_=>;$STATUS{$_}"} keys %STATUS),"\n" if DEBUG;
    
46. unless(%CHILDREN){ last; }
    
47. }
    
48. 
    
49. warn "Termination received, killing children\n" if DEBUG;
    
50. #-------------杀掉所有Child Process
    
51. kill TERM =>; keys %CHILDREN;
    
52. sleep while %CHILDREN;
    
53. warn "Normal termination.\n";
    
54. exit 0;
    
55. 
    
56. #---- 给launch_child cleanup child code
    
57. sub make_new_child{
    
58. die "can't fork :$!" unless(defined( my $child = fork()));
    
59. if($child){ # child>;0, so we're the parent
    
60. warn "launching child $child\n" if DEBUG;
    
61. $CHILDREN{$child} = 1;
    
62. }else{
    
63. do_child(); # child handles incoming connections
    
64. exit 0; # child is done
    
65. }
    
66. }
    
67. #--- 执行accept() loop fro each child ---
    
68. sub do_child{
    
69. my %status;
    
70. #--将%status与IPC::Shareable tie在一起
    
71. tie(%status,'IPC::Shareable', SHM_GLUE)
    
72. or die "Child $$: can't tiel \%status to shared memory: $!";
    
73. #----告知Parent Process，child process 状态已经改变
    
74. $status{$$} ='idle'; kill ALRM=>;getppid();
    
75. for(1..1000000){ }
    
76. #----告知Parent Process，child process 状态已经改变
    
77. $status{$$} ='busy'; kill ALRM=>;getppid();
    
78. #----告知Parent Process，child process 状态已经改变
    
79. for(1..1000000){ }
    
80. $status{$$} = 'done'; kill ALRM=>;getppid();
    
81. warn "child $$: done\n" if DEBUG;
    
82. }
    
83. #---- delete the child's PID from %STATUS.
    
84. sub cleanup_child{
    
85. my $child=shift;
    
86. delete $STATUS{$child};
    
87. }     
    

复制代码

deathcult

[4]
為什麼要用IO:oll？因為使用IO::Select時候，因為其儲存handle是存在。。。。。。
作者：apile

以下資料為本人閱讀Nework Programming With Perl的記要..
有興趣的自己研究研究...

=============================================
date: 2003/06/22

IO:oll的使用說明：
  在5.6版本的時候開始發展，功能完整的版本為0.04版。所以要注意的是IO:oll版本一定要是0.04以上。

為什麼要用IO:oll？因為使用IO::Select時候，因為其儲存handle是存在bit vector裡面，因此必須針對所有監控中的Handle一個一個去Scan，找出可以Read/Write的handle。因此在效能的Issue上，當遇到大量的handle需要監控時，就會產生效能上的降低。而IO:oll的機制則不是這麼回事，他同樣可以監控大量的HANDLE，但是利用array儲存這些handle，因為array的儲存機制，並不同於bit vector，並不需要一個一個去Scan這些handle，所以在效能上比較好。

  IO:oll只需要一個Object就可以處理所有的handle，透過bitmask將Event傳給被監控的Handle，一旦符合需求，可以從handle中取出。

IO:oll接受的Event(mask)：
可讀的
POLLIN:一般與有Priority的資料
POLLRDNORM：一般的資料
POLLRDBAND：有Priority的資料
POLLPRI：特別高的Priority
可寫的
POLLOUT：一般與有Priority的資料
POLLWRNORM：一般的資料
POLLWRBAND：有Priority的資料
有錯誤的
POLLHUP：HangUp發生
POLLNVAL：handle不合法
POLLERR：有Error發生，如果是Socket可用sockopt(SO_ERROR)取得Error內容

IO:oll的method
1.$poll=IO:oll->;new()：產生IP:oll的Object
2.$mask=$poll->;mask($handle,[$mask])
取得或設定目前handle的 event bitsmask，如果mask沒給，則目前的設定值回傳。如果有給mask則將該mask設定給該handle。如果mask為0，則從list將該handle移除。所有的handle預設都會監控(POLLNVAL、POLLERR、POLLHUP）。
3.$poll->;remove($handle)
同$poll->;mask($handle,0);
4.$events=$poll->;poll([$timeout])
等候有任何一個監控中的handle可以被讀取或寫入。回傳Event Type。
5.@handles=$poll->;handles([$mask])
取出符合mask的handles。
6.$mask = $poll->;events($handle)
取得$handles的所有mask。

1. 
   
2. #!/usr/bin/perl
   
3. # file : test.pl
   
4. # usage: test.pl [host] [port]
   
5. # 利用IO::Poll達到多工的技術
   
6. #--加載module
   
7. use strict;
   
8. use IO::Socket;
   
9. #--引用後面的constant
   
10. use IO::Poll qw( POLLIN POLLOUT POLLERR POLLHUP);
    
11. use Errno qw(EWOULDBLOCK);
    
12. #--設定Buffer的最大值
    
13. use constant MAXBUF =>;8192;
    
14. #--忽略掉HANG HUP的Signal
    
15. $SIG{PIPE} = 'IGNORE';
    
16. #--設定全域變數，兩個buffer兩個flag
    
17. my ( $to_stdout,$to_socket,$stdin_done,$sock_done);
    
18. #--取得 host and port
    
19. my $host = shift or die "Usage: test.pl host [port]\n";
    
20. my $port = shift || 'echo';
    
21. #--建立Socket
    
22. my $socket = IO::Socket::INET->;new("$host:$port") or die $@;
    
23. my $poll = IO::Poll->;new() or die "Can't create IO::Poll object";
    
24. #--一開始先將STDIN與$socket放入list中，並將其mask設定為POLLIN準備讀取。
    
25. $poll->;mask(\*STDIN =>; POLLIN);
    
26. $poll->;mask($socket =>; POLLIN);
    
27. #--設定標準輸出與$socket為noblocking mode
    
28. $socket->;blocking(0); # turn off blockingon the socket
    
29. STDOUT->;blocking(0);  # and on STDOUT
    
30. #--main loop，$poll->;handles會回傳所有正在監控中的handle
    
31. while($poll->;handles){
    
32. #--等候直到有事件符合
    
33.   $poll->;poll;
    
34.   # 處理可讀取的事件
    
35.   for my $handle ($poll->;handles(POLLIN|POLLHUP|POLLERR)){
    
36.     if($handle eq \*STDIN){
    
37.   #?#93;資料讀取表示STDIN已經終止，否則將資料放入to_socket buffer中
    
38.     $stdin_done++ unless sysread(STDIN,$to_socket,2048,length $to_socket);
    
39.     }
    
40.     elsif($handle eq $socket){
    
41.   # ?#93;資料讀取表示Socket已經讀取完畢，否則將資料附入to_stdout buffer中
    
42.    $sock_done++ unless sysread($socket,$to_stdout,2048,length $to_stdout);
    
43.     }
    
44.   }
    
45. 
    
46.   # 處理可寫入的事件
    
47.   for my $handle ($poll->;handles(POLLOUT|POLLERR)){
    
48.      if($handle eq \*STDOUT){
    
49.        my $bytes = syswrite(STDOUT,$to_stdout);
    
50.      # 假若不是EWOULDBLOCK，表示真的有Error發生，所以才無法寫入
    
51.        unless ($bytes){
    
52.           next if $! == EWOULDBLOCK;
    
53.           die "write to stdout failed: $!";
    
54.        }
    
55.      # 如果發生Partial Write將已經寫出的先清掉。
    
56.        substr($to_stdout,0,$bytes) = '';
    
57.      }
    
58.      elsif($handle eq $socket){
    
59.        my $bytes = syswrite($socket,$to_socket);
    
60.        unless ($bytes){
    
61.           next if $! == EWOULDBLOCK;
    
62.           die "write to socket failed: $!";
    
63.        }
    
64.        substr($to_socket,0,$bytes) = '';
    
65.      }
    
66.   }
    
67. } continue {
    
68.   # 每次While loop執行時都會執行到這兒
    
69.   # 先設定三個bitmask為0，表示將從list中將該handle移除
    
70.   my ($outmask,$inmask,$sockmask) = (0,0,0);
    
71.   # 設定stdout的mask，假如有資料要寫出去，則將其mask設為可寫(POLLOUT)
    
72.   $outmask = POLLOUT if length $to_stdout >; 0;
    
73.   # 當 to_socket的資料長度比MAXBUF大、或socket已經完結
    
74.   # 或stdin已經完結，都不成立時，則設定STDIN可讀取。
    
75.   $inmask = POLLIN unless length $to_socket >;= MAXBUF
    
76.                       or ($sock_done || $stdin_done);
    
77.   # 假如有資料要寫出去，設定$socket為POLLOUT（待寫)
    
78.   $sockmask = POLLOUT if length $to_socket>;0;
    
79.   # 同STDIN定義，但是|=表示附加上去，因為Socket可以同時讀寫
    
80.   $sockmask |= POLLIN unless length $to_stdout>;=MAXBUF or $sock_done;
    
81.   # 設定STDIN、STDOUT、Socket三個handle的bitmask
    
82.   $poll->;mask(\*STDIN =>; $inmask);
    
83.   $poll->;mask(\*STDOUT=>; $outmask);
    
84.   $poll->;mask($socket =>; $sockmask);
    
85.   # 如果$stdin_done為真且已經?#93;有資料送出至$socket了，則將$socket 關?#93;
    
86.   $socket->;shutdown(1) if $stdin_done and !length($to_socket);
    
87. }
    

复制代码

雨中漫步

截取中英文混合字符串，写得很罗嗦，请高人修改一下!
作者：雨中漫步

1. 
   
2. sub makelen($$)
   
3.   {
   
4.           my($sstr,$slen)=@_;
   
5.           my $makelen,$parity;
   
6.           $mslen=length($sstr);
   
7.           if($mslen>;$slen)
   
8.             {
   
9.                 for($mn=0;$mn<$slen;$mn++) #在要求的长度内
   
10.                   {
    
11.                           $ss=substr($sstr,$mn,1);
    
12.                           if(ord($ss)<127) #为英文
    
13.                             {
    
14.                                 $parity+=1;
    
15.                             }
    
16.                   }
    
17.                  if($parity%2==1) #含英文长度为奇数
    
18.                   {
    
19.                           if($slen%2==1) #如果所要求的长度也为奇数
    
20.                                 {
    
21.                                         $tmpstr=substr($sstr,0,$slen);
    
22.                             }
    
23.                           else #所要求的长度为偶数
    
24.                             {
    
25.                                     $tmpstr=substr($sstr,0,$slen-1);
    
26.                             }
    
27.                   }
    
28.                 else #含英文长度为偶数或者为0，0也为偶数
    
29.                   {
    
30.                           if($slen%2==1) #如果所要求的长度为奇数
    
31.                                 {
    
32.                                         $tmpstr=substr($sstr,0,$slen-1);
    
33.                             }
    
34.                           else #所要求的长度为偶数
    
35.                             {
    
36.                                     $tmpstr=substr($sstr,0,$slen);
    
37.                             }
    
38.                   }
    
39.                 $makelen=$tmpstr;
    
40.             }
    
41.           else
    
42.             {
    
43.                 $makelen=$sstr;
    
44.             }
    
45.           return $makelen;
    
46.   }
    

复制代码

slimzhao

To: 雨中漫步

可以拿下面的代码测试一下:

1. $str = "asdf中12 34国人民";
   
2. for(0..length($str) )
   
3. {
   
4.   print "$_=>;", substring($str, $_), "\$\n";
   
5. }

复制代码

长度为8, 9时不正确.

看一下这代码怎么样:

1. sub substring($$)
   
2. {
   
3.   my ($str, $len) = @_;
   
4.   my $retval = substr($str, 0, $len);
   
5.   $retval =~ /[\x7f-\xff]+$/s;
   
6.   chop($retval) if (length($&) % 2 == 1);
   
7.   return $retval;
   
8. }   

复制代码

lgjut

use encoding 'euc-cn', STDIN =>; 'euc-cn', STDOUT =>; 'euc-cn';

$str = "asdf中12 34国人民";
for(0..length($str) )
{
  print "$_=>;", substr($str, $_), "\$\n";
}

雨中漫步

获得本机的多个IP地址
本人是初学者，找了半天才找到这种获得多个IP的方法，原来就这么简单 ，希望能对初学者有所帮助！

1. 
   
2. #!c:/perl/bin/perl.exe
   
3. use strict;
   
4. use Socket;
   
5. use Sys::Hostname;
   
6. 
   
7. my $host = hostname();
   
8. print $host."\n";
   
9. 
   
10. my $name;
    
11. my $aliases;
    
12. my $type;
    
13. my $len;
    
14. my @thisaddr;
    
15. ($name,$aliases,$type,$len,@thisaddr)=gethostbyname($host);
    
16. 
    
17. foreach(@thisaddr)
    
18. {
    
19.         print inet_ntoa($_)."\n";
    
20. }
    

复制代码

y6cmE

1. 
   
2. #!e:/635/bin/perl.exe -w
   
3. use strict;
   
4. #####  Name:      xnnyy.pl
   
5. #####  Version:   0.0.0.1
   
6. #####  Author:    y6cmE[PerlChina]
   
7. #####  Contact:   www.perlchina.org
   
8. #####  Updated:   2003-9-21
   
9. $|=1;
   
10. open(F,">;xnnyy.txt") or die "Can't write output file!";
    
11. my $x=shift||3;
    
12. my $y=int($x/2);
    
13. my @z=(()x$x);
    
14. my($e,$v,$n,$m);
    
15. for(1..$x*$x){
    
16.         if($_ >; $x){
    
17.                 $n=(--$n+$x)%$x;
    
18.                 $m=(1+$m++)%$x;
    
19.                 if($z[$n][$m]){
    
20.                         $n=($n+2)%$x;
    
21.                         $m=($m-1)%$x;
    
22.                         $z[$n][$m]=$_;
    
23.                         print F "$_\t$n\t$m\n";
    
24.                 }
    
25.                 else{
    
26.                         $n=$n;
    
27.                         $m=$m;
    
28.                         $z[$n][$m]=$_;
    
29.                         print F "$_\t$n\t$m\n";
    
30.                 }
    
31.         }
    
32.         else{
    
33.                 $n=($x+$e--)%$x;
    
34.                 $m=(++$v+$y-1)%$x;
    
35.                 $z[$n][$m]=$_;
    
36.                 print F "$_\t$n\t$m\n";
    
37.         }
    
38. }
    
39. close F;
    
40. print "Enjoy";
    

复制代码