蔡逸竹

12.8 CGI 程式常見疑難
為何我的 CGI 程式執行時，出現 Server Error 500 的錯誤訊息？

引用:

見到的畫面如下所示:

The server encountered an internal error or misconfiguration and was
unable to complete your request. Please contact the server administrator,
mmm@nnn.com and inform them of the time the error occurred, and anything
you might have done that may have caused the error.

More information about this error may be available in the server error log.

CGI 程式出現 Server Error 500 的現象很平常，不管是 CGI 程式的新手或老手，都經常會碰到這個情況。 So，不要灰心! :-)

以下是我寫作 CGI 程式幾年來的一些偵錯經驗，提供給各位做參考：

引用:

1.CGI 程式中沒有印出: 欲輸出內容的 MIME 型態.

一般而言, 就是沒傳回 Content-type: text/html 再加上一列空白行分隔.

請檢查您的 CGI 程式是否有 print "Content-type: text/html\n\n";

2. 您的 CGI 程式呼叫 Perl 的 magic code 路徑不對.

在程式的第一行要放上 Perl 的呼叫路徑.

如 #! /usr/bin/perl 或 #! /usr/local/bin/perl

您可以 telnet 進主機之後, 下 which perl 指令來尋找.

或者向網管人員洽詢, 務必要查清楚 Perl 的正確路徑.

3. 欲開啟或寫入的檔案, 其絕對路徑或相對路徑錯誤.

例如 $guestbook_file="/home/your_dir/www/gbk.txt";

請查清楚此檔案的路徑是否正確?

4. 欲開啟或寫入的檔案或目錄, 其權限沒設好.

通常要寫入的檔案, 權限須設為 666, 僅供讀取的檔案, 權限設為 755.

或者讓 nobody 身份擁有寫入或讀取權.


5. 上傳 CGI 程式時, 沒有用 ASCII 模式上傳.

您是否錯用 Binary 模式上傳呢? 再用 ASCII 模式上傳一次吧?!

6. CGI 程式的語法有誤, 可能是忘了在某一列 Perl 敘述之後, 加上 ';' 這個結束符號,

或是忘了加上括號() { }. 或者是其它語法錯誤所致.

7. CGI 程式本身的權限屬性沒設好, 通常 CGI 程式設為 755, 或者讓 nobody 身份擁有讀取及執行權.

8. 您可能是在印出 html 語法時, 忘了把雙引號中的其它雙引號給 meta 掉(或稱作 escape 掉).

例如: print "<font color="red">Hello</font>\n"; 便是錯誤的語法.

應改成 print "<font color=\"red\">Hello</font>\n";

也就是說在雙引號中, 若要有雙引號, 應寫成 \" 來 替代 " .

比較方便的做法是使用 perl 的 qq, 可將上面改寫成:

print qq(<font color="red">Hello</font>\n);

或者, 使用 Here document 的寫法:

print <<HERE;

　<font color="red">Hello</font>
　..............................

HERE


9. 上傳至 Unix/Linux/FreeBSD 主機之後, 每列結尾出現 ^M 的符號.

請將這些符號刪除即可.

10.若您的程式有利用 DBI+DBD 撰寫 SQL 資料庫程式,

則當某些 SQL 語法錯誤時, 也會產生 Error 500.


11.您的程式有使用 die 語法來 catch error, 而沒有做適當的 "錯誤或例外處理".

12.您 require 某一個 perl file, 但該 perl file 並不存在, 或者路徑錯誤.

13.您引用的 Perl 模組(module), 並未安裝好,

或者, 您忘了加 use 語法來引用模組, 卻用了某一模組的函式功能.

14.在 Win95/98 中試圖使用 flock 語法來 "鎖定/解開" 檔案, 也會發生 Error 500.

蔡逸竹

14. 大量刪帳號
ols3scandir.pl

引用:

#! /usr/bin/perl
######################################################################
# 臥龍小三大量刪除帳號工具      Version 1.0.1 [for RedHat Linux]     #
# Copyright 1999 OLS3           mskuo@ms9.hinet.net                  #
# 程式名稱: ols3delact.pl  及  ols3scandir.pl [臥龍小三工具箱系列]   #
# 初版 11/01/99                 最後修改日期 11/23/99                #
# 發行站台: 訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 臥龍小三CGI天堂                 #
######################################################################
# 版權宣告:                                                          #
# Copyright 1999 OLS3 All Rights Reserved.                           #
# 本工具程式意旨供 RedHat Linux 愛好者使用,                          #
# 願以 GPL (GNU General Public Licence) 發行.                        #
######################################################################
# 注意事項:                                                          #
# 您必須審慎評估使用本程式是否會對您的軟硬體造成損害，若有任何意     #
# 外，本人不負任何責任。(換言之, 使用本程式要有不怕死的精神! ^_^)    #
######################################################################
# 使用方法:                                                          #
# 1. 以 root 身份登入主機, 然後將程式放入 /root 中, 並給予執行權!    #
# 如下所示:                                                          #
#          chmod u+x ols3scandir.pl 及 chmod u+x ols3delact.pl       #
#                                                                    #
# 2. 執行 ./ols3scandir.pl /home ?                                   #
#                                                                    #
# 這個步驟用來掃瞄 /home 之下有那些帳號目錄, 如果, 您的主機中, 帳號  #
# 是建置於 /home/users, 那麼, 就要執行 ./ols3scandir.pl /home/users  #
#                                                                    #
# 之後, 它會將帳號目錄名稱寫入 dir_list 這個記錄檔中, 您可以用 vi 來 #
# 編輯它, 將不想要刪除的帳號名稱去除.                                #
#                                                                    #
# 3. 執行 ./ols3delact.pl , 即可刪除大量帳號.(根據 dir_list 的記錄)  #
#                                                                    #
# 本程式會保護: /home/ftp, /home/httpd, /home/lost+found, /home/adm  #
# /home/webadm, /home/webmaster 等目錄及帳號, 不會予以刪除.          #
#                                                                    #
# 本程式完成以下幾件事:                                              #
#     a. 刪除自家目錄(Home Directory)                                #
#     b. 備份 /etc/passwd , /etc/shadow 及 /etc/group                #
#     c. 將帳號自 /etc/passwd , /etc/shadow, /etc/group 去除.        #
#                                                                    #
# 注意: 各個帳號的信包 "/var/spool/mail/帳號", 並沒有刪除!           #
# 一般而言, 新建的帳號大都沒有信包檔. 如果您要此一功能, 請自行增添.  #
#                                                                    #
# 4. 本程式自動幫您備份 /etc/passwd, /etc/shadow, /etc/group         #
#                                                                    #
# 備份檔名格式為:                                                    #
#    /etc/passwd-YYYYMMDDhhmmss 及 /etc/shadow-YYYYMMDDhhmmss        #
#    (如:/etc/passwd-19991101093217  /etc/shadow-19991101093217)     #
######################################################################
use strict;
my $dir=$ARGV[0];
if (!$ARGV[0]) {
  print "Hey! Notice!\n";
  print "*** Usage: ./scandir.pl Directory\n";
  print "*** Example: ./scandir.pl /home\n";
  exit;
}

opendir (DIR, $dir) || die "$!\n";
my @file=readdir(DIR);
closedir(DIR);

open(FHD, "> dir_list") || die "$!\n";
my $file;  
foreach $file (@file) {
  unless (($file eq '.')||($file eq '..')) {
    if (-d "$dir/$file") {print FHD "$dir/$file\n";}
  }
}
close(FHD);

print qq(Please check the file: "dir_list"\n);
print qq(and run ./delact.pl\n);

ols3delact.pl

引用:

#!/usr/bin/perl

use strict;
use File::Copy;
use File::Basename;

$|=1;

open(FHD, "dir_list") || die "$!\n";
my @dir=<FHD>;
close(FHD);

my $time=get_time();
my $backup_pwd="/etc/passwd"."-$time";
my $backup_shadow="/etc/shadow"."-$time";
my $backup_group="/etc/group"."-$time";
copy("/etc/passwd", $backup_pwd);
copy("/etc/shadow", $backup_shadow);
copy("/etc/group", $backup_group);

chmod 0400 , $backup_shadow;

system("/usr/sbin/pwunconv");
my $dir;
foreach $dir (@dir) {
  chomp $dir;
  unless (($dir eq '/home/ftp')||
          ($dir eq '/home/httpd')||
          ($dir eq '/home/lost+find')||
          ($dir eq '/home/webadm')||
          ($dir eq '/home/adm')||
          ($dir eq '/home/webmaster')||
          ($dir eq '/home/ols3')
          )
  { system("rm -Rf $dir");}
}

open(PWD, "/etc/passwd") || die "$!\n";
my @act=<PWD>;
close(PWD);

open(PWD, "> /etc/passwd") || die "$!\n";
my $line; my ($f1, $f2);
foreach $line (@act) {
  ($f1, $f2)=split(/:/, $line);
  unless (killit($f1, \@dir)) {
    print PWD $line;
  }
}
close(PWD);
system("/usr/sbin/pwconv");

open(GRP, "/etc/group") || die "$!\n";
my @grp=<GRP>;
close(GRP);

open(GRP, "> /etc/group") || die "$!\n";
foreach $line (@grp) {
  ($f1, $f2)=split(/:/, $line);
  unless (killit($f1, \@dir)) {
    print GRP $line;
  }
}
close(GRP);

print "Done!\n";

sub killit {
  my ($name, $harray)=@_;
  my ($dir,$account);
  if (
      ($name eq 'ftp')||
      ($name eq 'httpd')||
      ($name eq 'lost+found')||
      ($name eq 'webadm')||
      ($name eq 'adm')||
      ($name eq 'webmaster')||
      ($name eq 'ols3')
     )
  { return 0;}
  foreach $dir (@$harray) {
    $account=basename($dir);
    if ($name eq $account) {
      return 1;
    }
  }
  return 0;
}

sub get_time {
  my ($sec,$min,$hour,$day,$mon,$year)=localtime(time);
  $mon++;
  if (length ($mon) == 1) {$mon = '0'.$mon;}
  if (length ($day) == 1) {$day = '0'.$day;}
  if (length ($hour) == 1) {$hour = '0'.$hour;}
  if (length ($min) == 1) {$min = '0'.$min;}
  if (length ($sec) == 1) {$sec = '0'.$sec;}
  $year=$year+1900;
  my $alltime="$year$mon$day$hour$min$sec";
  return $alltime;
}

蔡逸竹

15. 過濾求職信病毒
Perl 在病毒防治上也非常好用。

引用:

#! /usr/bin/perl
#
# 本程式用來濾除 /var/spool/mail 信包檔中的 "求職信" 病毒。
# 想法如下:
# 信件尚未放入 /var/spool/mail 之前, 您可以用 procmail 來濾除,
# 但先前已餵入 /var/spool/mail 中的病毒信件, 怎麼辦呢? 因此, 才有這隻程式的產生.
#
# 不過, 本人無法保證它一定會百分之百濾除;
# 使用前您應該自己對執行時可能承擔的風險先考慮清楚!
# 若有任何損失, 本人概不負責.
#
# 使用前, 您應先將 /var/spool/mail 這個目錄予以備份.
# (註: 若是 FreeBSD, 則可能是 /var/mail 這個目錄)
# 例如:
# cp -Rp /var/spool/mail /tmp/save.mail
# su - 成 root 身份
# 將本程式放入 /var/spool/mail 中, chmod 755 filter_mail.pl
# 執行 ./filter_mail.pl
# 它會將 /var/spool/mail 中的信包檔在 /tmp/filt_msg_tmp 目錄中, 一封一封解開.
# 然後予以過濾寫回. 執行結束之後, /var/spool/mail 中的權限仍然會保持原樣.
# 所有解開的信件檔, 都在 /tmp/filt_msg_tmp 目錄中, 若一切正常, 可以將該目錄刪除.
# 若有不正常, 可自行用 cat 指令將信件檔組合回去, 或將原先備份的信包檔蓋回去.
#
# 本程式稍加修改, 即可用來過濾其它的病毒.
#
# 版權宣告:
# Copyright (c) 2002 by OLS3(ols3@訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 04/20/2002
# 本程式為 GPL 軟體.
# 發佈這一程式的目的是希望它有用，但沒有任何擔保。
# 甚至沒有適合特定目的而隱含的擔保。
# 更詳細的情況請參考 GNU 通用公共許可證。
# 當您修改和重新發佈本軟體時，請保留版權宣告的文字部份。
#
# $Id: chapF.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $

use strict;

show_title();

while(my $msg_file=<*>) {
  if ($msg_file eq 'filter_mail.pl') { next;}
  print "Processing spool mail ---> $msg_file\n";
  open(FHD, "$msg_file") || die;
  flock(FHD, 2);
  # 將信包檔的每一封信分開存放, 以數字為檔名, 放在 /tmp/filt_msg_tmp/使用者帳號/ 目錄下
  split_msg(\*FHD, $msg_file);
  flock(FHD, 8);
  close(FHD);

  # 處理這些信件
  proc_msg($msg_file);
  print "Done!             \n";
}

sub show_title {
  system("clear");
  print <<HERE;
/*--------------------------------------------*/
/* Filter spool mail v1.0.1 (GPL)             */
/* Copyright (c) 2002 written by OLS3         */
/*--------------------------------------------*/
HERE

}

sub split_msg {
        my $fh = shift;
        my $user_id=shift;
        my $count=1;
        my $s=1;
        my $bline='ols3Tp1iz2a134598132308abcdefghijk123pisa#############';
        my $line;
        my $msg_start='^From\s.*?@?.*?\s+?\w+\s\w+\s\d+\s\d+:\d+:\d+\s\d+';
        my $msg_name='';
        my $t2_dir = "/tmp/filt_msg_tmp";
        my $tmp_dir = "$t2_dir/$user_id/";
        if (! -e $t2_dir) { mkdir $t2_dir, 0777; }
        if (! -e $tmp_dir) { mkdir $tmp_dir, 0777; }
        my $k=1;
        while($line = <$fh>) {
                print print_process_status($k);
                # 處理第一封信件
                if ($s == 1) {
                        $msg_name= $tmp_dir . $count . '.msg';
                        open(FH, "> $msg_name")||die;
                        $s=0;
                }

                if (($line =~ /$msg_start/) && !$bline) {
                        # 關檔結束寫入上一封信
                        close(FH);
                        # 開檔寫入新的一封信
                        $count++;
                        $msg_name= $tmp_dir . $count . '.msg';
                        open(FH, "> $msg_name")||die;
                }


                $bline=$line;
                chomp $bline;

                print FH $line || die;
                $k++;
        }
        close(FH);
}

sub get_ugid {
        my @attr=stat(shift);
        return @attr[4,5];
}

sub proc_msg {
        my $msgf=shift;
        my ($uid, $gid)=get_ugid($msgf);

        # 刪除信包檔
        if (-e $msgf) {
          unlink $msgf;
        }

        # 開一個空檔
        open(FHE, "> $msgf");
        close(FHE);

        # 修改屬性
        chown($uid, $gid, "$msgf");
        chmod 0660, $msgf;

        open(FHE, ">> $msgf");
        flock(FHE, 2);
        my $i=1;
        while(my $fn=glob("/tmp/filt_msg_tmp/$msgf/*.msg")) {
          print print_process_status($i);
          if (!filt_msg($fn)) {
            open(F, "$fn") || die;
            while(<F>) {
              print FHE;
            }
            close(F);
          } else {
            print "find virus! delete $fn !\n";
          }
          $i++;
        }
        flock(FHE, 8);
        close(FHE);
}


sub filt_msg {
        my $msg=shift;
        my ($sm, $fm, $bm);
        my $s_001 = "\<iframe.*?src=.*?height=3D0.*?width=3D0\>";
        my $t_001 = '^Content-Type: application/octet-stream';
        my $t_002 = '^Content-Type: audio/x-midi';
        my $t_003 = '^Content-Type: audio/x-wav';
        my $f_001 = 'name=.*?\.scr';
        my $f_002 = 'name=.*?\.exe';
        my $f_003 = 'name=.*?\.pif';
        my $f_004 = 'name=.*?\.bat';
        open(FHD_msg, "$msg") || die "open msg error!\n";
        while(my $line=<FHD_msg>) {
          if ($line =~ /$s_001/) { $sm=1; }
          if ($line =~ /$t_001|$t_002|$t_003/) { $fm=1; }
          if ($line =~ /$f_001|$f_002|$f_003|$f_004/) { $bm=1;}
          if ($sm || ($fm && $bm)) { return 1; }
        }
        return 0;
}


sub print_process_status {
    my $i=shift;
    my $j = $i % 4;
    SWITCH : {
        $j == 0 && do { print STDERR " (|)\r";  last SWITCH; };
        $j == 1 && do { print STDERR " (/)\r";  last SWITCH; };
        $j == 2 && do { print STDERR " (-)\r";  last SWITCH; };
        $j == 3 && do { print STDERR " (\\)\r"; last SWITCH; };
    }
}

蔡逸竹

16. 掃瞄
子網域掃瞄

Webscan.pm

引用:

package S3::Webscan;

# $Id: chapG.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $

use 5.006;
use strict;
use warnings;
use Carp qw(croak);
require Exporter;

our @ISA = qw(Exporter);

use Socket;
use Net:ing;

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration        use S3::Webscan ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
       
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
       
);

our $VERSION = '0.02';


# Preloaded methods go here.


sub new {
        my $pkg = shift;
        my $self = { p =>  Net:ing->new('icmp') };
        bless($self, $pkg);
        return $self;
}


sub pingit {
        my ($self, $host, $second)=@_;
        return $self->{p}->ping($host, $second);
}


sub printWebServer {

        my ($selft, $host)=@_;

        socket(FH, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || croak("Socket failed: $!");
        my $sin=sockaddr_in(80, inet_aton($host));
        if (!connect(FH, $sin)) {
                print "Unable to connect to $host.\n";
                close(FH); return;
        }

        my $old_fh=select(FH);
        $|=1;
        select($old_fh);

        print FH "GET / HTTP/1.0\n\n";

        while (<FH>) {
                if (/^Server: (.+)/) {
                        print "$host -\> $1\n"; close(FH); return;
                }
        }
        print "$host -> unknow web server type!\n";
}

sub closeping {
        my $self=shift;
        $self->{p}->close();

}

sub usage {

        print <<HERE;
Usage:
-----------------------------------------------------------------
chmod +x ols3webscan.pl

then

./ols3webscan.pl IP

OR

./ols3webscan.pl net/mask
-----------------------------------------------------------------
ex1:
./ols3webscan.pl 10.0.0.1

ex2:
./ols3webscan.pl 10.0.0.0/24    for 1C subnetwork
./ols3webscan.pl 10.0.0.0/25    for 1/2C subnetwork
./ols3webscan.pl 10.0.0.0/26    for 1/4C subnetwork

note:
./ols3webscan.pl 10.0.0.1/32 is same as ./ols3webscan.pl 10.0.0.1
-----------------------------------------------------------------
HERE

        exit;
}

sub getnodes {
        my ($self, $j)=@_;
        if (!$j) { return 1; }
        $j == 24 && do { return 253; };
        $j == 25 && do { return 126; };
        $j == 26 && do { return 61;  };
        $j == 27 && do { return 29;  };
        $j == 28 && do { return 13;  };
        $j == 29 && do { return 5;   };
        $j == 30 && do { return 1;   };
        $j == 32 && do { return 1;   };
        return 1;
}


1;
__END__
#

=head1 NAME

S3::Webscan - Perl extension for scaning web server in your network.

=head1 SYNOPSIS

  use S3::Webscan;
  

=head1 ABSTRACT

  S3::Webscan.

=head1 DESCRIPTION

Perl extension for scaning web server in your network.

=head2 EXPORT

None by default.


=head1 SEE ALSO

訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。

=head1 AUTHOR

OLS3 <lt>ols3@訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by OLS3

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

ols3webscan.pl

引用:

#! /usr/bin/perl
# $Id: chapG.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $
#
# 目前只提供 scan C class，若要 scan B class，請自行修改。

use S3::Webscan;
use strict;

my $ping_time_out=1;
my $nethost=$ARGV[0];
my $n = S3::Webscan->new();

unless ($nethost) { $n->usage(); }

my ($net, $mask)=split(/\//, $nethost);

if ($net !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { $n->usage(); }

my $nodes=$n->getnodes($mask);

my ($n1,$n2,$n3,$n4)=split(/\./, $net);

for (my $i<=0; $i<$nodes; $i++) {
        if ($n4 < 1) { $n4=1; }
        if ($n4 > 253) { $n4=253; }
        my $host="$n1.$n2.$n3.$n4";
        unless ($n->pingit($host, $ping_time_out)) {
                print "$host is not alive!\n";
        } else {
                $n->printWebServer($host);
        }
        if ($n4++==253) { last; }
}

$n->closeping();

蔡逸竹

17. 網域名稱系統
正解

引用:

#! /usr/bin/perl

use strict;
use Socket;

print <<HERE;
請輸入您想查詢的完整主機網域名稱?
FQDN ?
HERE

while (<>) {
  chomp;
  if ($_ eq 'exit') { last; }
  my $paddr = gethostbyname($_);
  unless ($paddr) {
    print "$_ => ?\n";
    next;
  }

  my $daddr = inet_ntoa($paddr);
  print "$_ => $daddr\n";
}

# 可能輸出結果：

請輸入您想查詢的完整主機網域名稱?
FQDN ?
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 => 163.26.200.3
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 => 168.95.1.88
tw.yahoo.com
tw.yahoo.com => 202.1.237.21
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 => 66.187.232.50
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。
訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 => 207.46.134.190

反解

引用:

#! /usr/bin/perl

use strict;
use Socket;

my $A = '^\d+\.\d+\.\d+\.\d+$';

system("/usr/bin/clear");

print "反解模擬器 v1.0\n";
print "請輸入要反解的 IP ? (^C 或 exit可離開)\n\$反解\> ";

my $i=0;
while (<>) {
  if (++$i > 5) {system("/usr/bin/clear"); $i=0;}
  chomp;
  last unless ($_ ne 'exit');
  unless (/$A/o) {print "您輸入的不是合法的IP格式!\n"; next;}
  my $name = gethostbyaddr(inet_aton($_), AF_INET);

  #$name ||= '?'; # 此式形同: $name = $name || '?';
  $name = $name || '無法查得(可能無法連接或反解未授權)';

print "$_ => $name\n";
  print "\n請輸入要反解的 IP ? (^C 或 exit可離開)\n\$反解\> ";
}

# 可能輸出結果：

反解模擬器 v1.0
請輸入要反解的 IP ? (^C 或 exit可離開)
$反解> 163.26.200.1
163.26.200.1 => dns.tnc.edu.tw

請輸入要反解的 IP ? (^C 或 exit可離開)
$反解> 168.95.1.1
168.95.1.1 => dns.hinet.net

請輸入要反解的 IP ? (^C 或 exit可離開)
$反解>

蔡逸竹

18. 網蟲偵測
偵測 W2K Nimda 網蟲

引用:

package Apache:etect_worms;
#----------------------------------------------------------------#
# $Id: chapI.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $
# $Log: chapI.sgml,v $
# Revision 1.1.1.1  2003/08/14 00:26:12  ols3
# perl_intro
#
# Revision 1.3  2002/02/15 01:36:32  OLS3
# *** empty log message ***
#
# Revision 1.2  2002/01/06 17:01:47  OLS3
# 網蟲偵測模組
#
#----------------------------------------------------------------#

use strict;
use vars qw($VERSION);
use Apache::Constants qw(OK DECLINED FORBIDDEN);
use Cache::FileCache;
use Symbol 'gensym';

$VERSION = 1.00;

my %cache_options = ('default_expires_in' => 86400 );

sub handler
{
    my $r = shift;

    my $file_cache = new Cache::FileCache(\%cache_options);

    unless ($file_cache) {
        return DECLINED;
    }

    my $remote_ip_address = $r->get_remote_host();

    my $visited = $file_cache->get($remote_ip_address);

    unless($visited) {
      my $fh = Apache->gensym;
      my $log_file="/home/apache2/lib/perl/Apache/worm_list." . get_date();
      open($fh, ">> $log_file");
      print $fh "$remote_ip_address\n";
      close($fh);
      $file_cache->set($remote_ip_address, 1);
    }

    return FORBIDDEN;

}

sub get_date {

  my ($sec,$min,$hour,$day,$mon,$year)=localtime(time);

  $mon++;
  if (length ($mon) == 1) {$mon = '0'.$mon;}
  if (length ($day) == 1) {$day = '0'.$day;}
  $year+=1900;
  my $date="$year$mon$day";
  return $date;
}

1;

__END__

wormlist.cgi

引用:

#! /usr/bin/perl
# $Id: chapI.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $
#
# $Log: chapI.sgml,v $
# Revision 1.1.1.1  2003/08/14 00:26:12  ols3
# perl_intro
#
# Revision 1.1  2002/01/06 17:03:06  OLS3
# Initial revision
#
use strict;

my $h = parse_input();

my $d=$h->{d};
if ($d) { unless ($d =~ /^200\d{5}$/) {no_this_day();}};
my $log_file;

unless ($d) { $d = get_date(); }

$log_file="/home/apache2/lib/perl/Apache/worm_list.$d";

print <<HTML_HERE;
    <html>
    <head>
    <meta HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=big5">
    <title>網蟲偵測程式</title>
    </head>
    <body bgcolor="white">
    <H3>以下Win2000主機感染 Nimda/CodeRed 網蟲，請儘速修補主機漏洞!</H3>
網蟲偵測程式 Apache:etect_worms v1.0.1 (c) 2001 written by OLS3
<br><a href="http://www.tnc.edu.tw">回教網中心</a> <a href="javascript:history.back()">回上一頁</a>
<br>
<font color="red">修補資訊</font>: <a href="http://www.cc.ncku.edu.tw/virus/Nimda/index.htm">W32/Nimda</a>
<a href="http://www.cc.ncku.edu.tw/virus/CodeRed/">CodeRed</a> (成大區網提供)
    <hr>
日期: $d (觀看時, 建議: 先拿掉您的瀏覽器中的 PROXY 設定.)
HTML_HERE

if (-f $log_file) {
    open(FHD, "$log_file");
    my @all=<FHD>;
    close(FHD);
    foreach (@all) {
        if (is_net_TNC($_)) {
            print "<br><b><font color=red>縣內主機</font></b> --------> $_";
        } else {
            print "<br>縣外主機 --------> $_";
        }
    }
} else {
    print "<br>本日尚未有資料\n";
}

print <<HTML_END;
<br><br>
<hr>
這是一個 Nimda /CodeRed 網蟲偵測公告的 Apache 模組, 可和 Apache 結合在一起, 並可防止 Linux 主機被咬.
Linux 主機被咬並無大礙, 只是記錄檔中常常會有一堆訊息, 本模組可拒絕 Nimda/CodeRed 攻擊!
<br>請各校經常觀看此一公告程式, 若貴校 W2000 主機名列其中, 請儘速修補漏洞.
<p>記錄檔<br>
HTML_END

history_list();


print <<HTML_END2;
</body>
</html>

HTML_END2


sub get_date {
  my ($sec,$min,$hour,$day,$mon,$year)=localtime(time);
  $mon++;
  if (length ($mon) == 1) {$mon = '0'.$mon;}
  if (length ($day) == 1) {$day = '0'.$day;}
  $year+=1900;
  my $date="$year$mon$day";
  return $date;
}

sub is_net_TNC {
    my $ip=shift;
    if ($ip =~ /^163\.26\.(\d+)/) {
        ($1 >= 80 && $1<=206) ? return 1 : return 0;
    } else {
        return 0;
    }
}

# 列出過去的記錄
sub history_list {
    my @history_list=glob("/home/apache2/lib/perl/Apache/worm_list.*");
    foreach (@history_list) {
        my ($n, $d)=split(/\./);
        print qq(<a href="/perl/worm_list.cgi?d=$d">$d</a><br>\n);
    }
}

sub parse_input {
        my $temp=$ENV{'QUERY_STRING'};
        my @pairs=split(/&/,$temp);
        my %OLS3;
        foreach my $item(@pairs) {
                my ($key,$content)=split (/=/,$item,2);
                $content=~tr/+/ /;
                $content=~ s/%(..)/pack("c",hex($1))/ge;
                $OLS3{$key}=$content;
        }
        return \%OLS3;
}

sub no_this_day {
    print "沒有這一天的記錄!\n"; exit;
}

蔡逸竹

19. 套件自動更新
使 RPM 檔可以定期更新

urh73.pl

引用:

#! /usr/bin/perl
#---------------------------------------------------------------
# 說明:
#
# 這支程式, 用來幫助 RedHat 7.3 的主機, 由台南縣教網中心 FTP 站台
# (ftp.tnc.edu.tw)
# 自動下載 RPM 檔, 且自動做更新的動作. 可減少各校網管人員的負擔.
# 您只要每週做一次, 即可將您的主機 update 到最新的狀態(up-to-date)
# 本程式主要幫您做環境佈置; 而自動下載及更新的功能, 則借用 autoupdate.
#
# *** 注意: 您必須是 RedHat 7.3 的主機, 才適合使用這個套件. ***
#
# 不過, 本人無法保證它一定會百分之百運作正常;
# 使用前您應該自己對 *執行時可能承擔的風險* 先考慮清楚!
# 若有任何損失, 本人概不負責.
#
# 使用前, 您應先將詳讀 README 這個檔案.
#
#---------------------------------------------------------------
# 版權宣告:
# Copyright (c) 2002 by OLS3(ols3@訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。 07/02/2002
# 本程式為 GPL 軟體.
# 發佈這一程式的目的是希望它有用，但沒有任何擔保。
# 甚至沒有適合特定目的而隱含的擔保。
# 更詳細的情況請參考 GNU 通用公共許可證。
# 當您修改和重新發佈本軟體時，請保留版權宣告的文字部份。
#
# $Id: chapJ.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $
#---------------------------------------------------------------

use strict;
use File::Copy;

system("clear");
the_title();

my $prefix_update_dir=check();

install_require_rpm('Perl-RPM-0.40-5.6.1.i386.rpm');
install_require_rpm('autoupdate-4.3.3-1.noarch.rpm');

mk_require_dir($prefix_update_dir);

print "\nInstall OK! \nNow, you can exec the program: *** 'autodld' ***\n";
print "\n*** OR *** set crontab as follow:\n\n";
print "#-----------------------------------#\n\n";
my $week=int(rand 6)+1;
my $hour=int(rand 6)+1;
print "crontab -u root -e\n\n";
print "0 $hour * * $week /usr/sbin/autodld\n\n";
print "#-----------------------------------#\n\n";
print "The auotupdate directory is $prefix_update_dir/autoupdate\n";
print "After you run the autodld, you can check it.\nAnd remove all the *.rpm in the directory.\n";
print "Good Luck to you!\n\nOLS3 (ols3\@訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。\n\nhttp://teacher.mdjh.tnc.edu.tw/~ols3/\n\n";


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

sub the_title {
print <<HHH;
/*--------------------------------------------*/
/* autoURPM v1.0.1 2002 (GPL) written by OLS3 */
/* (reuse of autoupdate)                      */
/*--------------------------------------------*/

Checking the version of your RPM .....

Mmmmmmmmmm...........................

HHH

}

sub check {
  redir_temp_open();
  my ($max, $max_mount)=check_psize();
  redir_temp_close();
  if ($max < 418700) {
    print "Note!!!! All your HD partitions are less than 418MB.\n";
    print "This will get some truble...\n";
    print "Do you still want to do it ? (y/n)\n";
    my $answer=<>;
    chomp $answer;
    if (lc($answer) ne 'y') {die "Stop Now....\n Stop OK!\n"};
  }
  return $max_mount;
}

sub redir_temp_open {
  open SAVEOUT, ">&STDOUT";
  open SAVEERR, ">&STDERR";
  open STDOUT, "> check.tmp" or die;
  open STDERR, ">&STDOUT" or die "Can't dup stdout";
  select STDERR; $|=1; select STDOUT; $|=1;
}

sub redir_temp_close {
  close STDOUT; close STDERR;
  open STDOUT, ">&SAVEOUT";
  open STDERR, ">&SAVEERR";
}

sub mk_require_dir {
  my $prefix=shift;
  if (-e '/var/spool/autoupdate') {
        unlink  '/var/spool/autoupdate';
        rmdir  '/var/spool/autoupdate';
  }
  if (-e "$prefix/autoupdate") {
        unlink "$prefix/autoupdate/autoprovides.db";
        unlink "$prefix/autoupdate/*.rpm";
        rmdir "$prefix/autoupdate";
  }
  mkdir "$prefix/autoupdate", 0777;
  open(FHD, "> /etc/autoupdate.d/redhat.dld") || die;
  print FHD <<HERE;
Host=ftp.tnc.edu.tw
DldAll=1
FTPRetry=2
FTPWait=10
DldRecursive=0
Passive=1
Dir=/Sysop/redhat/updates/7.3/en/os//

HERE

  close(FHD);
  open(FHD, "> /etc/autoupdate.d/autoupdate.conf") || die;
  print FHD <<HERE2;
# /etc/autoupdate.d/autoupdate.conf
Verbose=1
Quiet=0
Warnings=1
RPMNameWarnings=1
DoUpdate=1
DoInstall=0
DoKernel=0
DoInitRD=1
DoBoot=1
DoDld=1
DoMerge=0
DoPurge=0
CleanUp=1
CleanUpKernel=1
#BootManager=lilo
BootAddAsNew=0
KernelExt=smp,enterprise,bigmem,debug,BOOT
Repackage=0
#QueryHeaders=1
#QueryDatabase=1
CheckSig=0
CheckGPG=0
Resolve=1
DldUseDB=1
BestMatch=1
RemoveBad=1
Recursive=0
UseLWP=0
#LWPProtocols=http,https
DoLog=1
#LogFile=
#PostUpdateScript=/sbin/SuSEconfig
#PostDldScript=
DefaultUser=anonymous
DefaultPass=`echo autoupdate@`hostname -f``
DistVersion=`/etc/autoupdate.d/distversion.sh`
ShellEscapes=0
UpdateDir=$prefix/autoupdate
RPMDir=
DldMatch=0
MergeMatch=0
#Exclude=^k_
#Include=

HERE2

  close(FHD);
  copy('autoprovides-redhat-7.3.db', "$prefix/autoupdate/autoprovides.db");

  system('/bin/ln', '-sf', "$prefix/autoupdate", '/var/spool/autoupdate');
}

sub install_require_rpm {
  my $rpm_file=shift;
  if (-e $rpm_file) {
    system('/bin/rpm', '-Uvh', "$rpm_file");
  } else {
    die "$rpm_file ????? existed\n";
  }
}

sub check_psize {
  system('/bin/df');
  open(FHD, "check.tmp") || die;
  my @all=<FHD>;
  close(FHD);
  my $max=0; my $max_mount='';
  foreach my $line (@all) {
    my ($pt, $n1, $n1, $size, $n2, $mount, $n3)=split(/\s+/, $line);
    if (($size*1)>$max) { $max=$size; $max_mount=$mount; }
  }
  return ($max,$max_mount);
}

蔡逸竹

20. 讀取 DBF 檔
Perl 可以讀取 DBF 的檔案喔!

引用:

#! /usr/bin/perl

# $Id: chapK.sgml,v 1.1.1.1 2003/08/14 00:26:12 ols3 Exp $

use Xbase;

$db=new Xbase;

system("clear");

my $COPYRIGHT=<<C1;
#---------------------------------------------------------
# dbf2csv.pl --- SFS3 學務系統轉DBF檔工具
# Written by OLS3 ver 1.0.2 (ols3@訪客無法瀏覽此圖片或連結，請先 註冊 或 登入會員 。
# Copyright (C) 2003 OLS3
# 本程式是自由軟體，可以依與 Perl 相同的授權條款散佈。
#
# 這個小程式可以幫您，將以前省教育廳國中學務系統中
# 的學生基本資料XBASIC??.DBF 轉成可以匯入 SFS3 學務系統的
# csv 檔，您只要將該 csv 檔，由：
# 教務 -> 註冊組 -> 匯入資料 -> 匯入萬豐版學生資料 ，
# 便可以很輕鬆地轉入學生基本資料。
# 往後會再增加其它轉入介面
# TODOLIST : 擴增現有 "簡易匯入介面"
#
# 使用法：./dbf2csv.pl
# 請將 xbasic??.dbf 和本程式放在同一目錄下。
#---------------------------------------------------------
C1

print $COPYRIGHT;

while (!$dbf) {
        print "\n請輸入學生基本資料DBF檔名？\n(Please keyin xbasic file of students)
\n格式: xbasic??.dbf 不計大小寫。\n(Format is xbasic??.dbf and do case-insensitive matching.) ";
        $dbf=<>;
        chomp $dbf;
        if (! -f $dbf) {
                print "\n $dbf 這個檔案不存在喔!\n($dbf not found! Please try again!)\n";
                $dbf=''; next;
        }
        unless ($dbf =~ /xbasic(\d\d)\.dbf/i) {
                print "\n $dbf 不是學生基資料檔喔!\n($dbf is not xbasic file of students! Please try again!)\n";
                $dbf='';
        }
        $tmp_year=$1;
}

if ($tmp_year) {
        while (lc($ans) ne 'y') {
                print "\n這批學生的入學年是 $tmp_year 嗎(請回答y/n)？ (year=$tmp_year ? Please answer y/n ?)";
                $ans=<>;
                chomp $ans;
                if (lc($ans) eq 'y') {
                        $use_tmp_year=1;
                } else { $ans='y'; }
         }
}


if (!$use_tmp_year) {
  while (!$in_year) {
        print "\n請輸入這批學生的入學年？ (如 91 入學，請填入 91)\n(Please keyin year ?)";
        $in_year=<>;
        chomp $in_year;
        if ($in_year && ($in_year !~ /^\d{2,3}$/)) {
          print "\n錯誤! 這裡只能輸入2~3位數 ! 請再來一次!
\n(Error! year only can be 2 or 3 digits number.\nPlease try again.)\n";
          $in_year='';
        }
  }
} else { $in_year=$tmp_year; }


my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);

# 年級
$now_year=$year-$in_year-11;

if ($now_year < 1 || $now_year > 3) {
        print "\n$in_year 入學年有誤，請再檢查一下!\n"; exit;
}


while (!$seme) {
        print "\n請輸入要轉入的學期是第1學期或第2學期？\n(Please keyin seme number?)";
        print "\n以上這項資訊用來決定要取上學期或下學的班級座號。 ";
        $seme=<>;
        chomp $seme;
        if ($seme && ($seme != 1 && $seme != 2)) {
                print "\n錯誤! 這裡只能輸入 1 或 2 ! 請再來一次!
\n(Error! seme only can be number 1 or 2.\nPlease try again.)\n";
                $seme='';
        }
}

while (!$area_code) {
        print "\n請輸入貴校當地所在的郵遞區號？\n(Please keyin area code number?) ";
        $area_code=<>;
        chomp $area_code;
}

while (!$town) {
        print "\n貴校所在地為 鎮 或 鄉 或 區?\n請輸入 鎮/鄉/區 其中一個中文字： ";
        $town=<>;
        chomp $town;
}

$class=(25 + ($now_year-1)*4 + ($seme -1)*2);
$seat =(26 + ($now_year-1)*4 + ($seme -1)*2);

print "\n請按 Enter 鍵開始轉換 ....\n(Please press Enter key to continue ....)";
my $ans=<>;

my ($tmp_output, $nouse)=split(/\./, $dbf);

$tmp_output .= ".csv";

open(F, "> $tmp_output") || die;

print F "代號,姓名,性別,入學年,班級,座號,生日(西元),身份證字號,父親姓名,
母親姓名,郵遞區號,電話,住址(不含縣市?鎮),緊急聯方式\n";

$db->open_dbf("$dbf");
print $db->dbf_type, "\n";

while (!$db->eof) {
        @fields=$db->get_record;

        my $sex;
        if (!$fields[3]) { $sex=2; } else { $sex=1; }

        my ($y,$m,$d);
        $y=substr $fields[4],0,4;
        $m=substr $fields[4],4,2;
        $d=substr $fields[4],6,2;

        my ($father,$mother);

        if ($fields[12] eq '父子' || $fields[12] eq '父女') {
                $father=$fields[11]; $mother=''; } else { $father=''; $mother=$fields[11];
        }

        my ($nouse, $addr) = split(/$town/, $fields[8]);
        if (!$addr) { $addr = $fields[8]; }

        if ($fields[0]) {
                print F "$fields[0],$fields[1],$sex,$in_year,$fields[$class],$fields[$seat],
$y/$m/$d,$fields[2],$father,$mother,$area_code,$fields[10],$addr,$fields[14]\n";
          }
        $db->go_next;
}

close(F);
$db->close_dbf;

print "\n完成! (OK!) --> $tmp_output\n\n";

蔡逸竹

21. 找尋大檔案

引用:

#! /usr/bin/perl

use File::Find;

# -s 會檢查檔案大小是否為 0，並且傳回 file size
# 本程式利用 -s 的特性，一面尋找大於 1MB 的檔案，也一面秀出其檔案大小。

find( sub { print "$_ -> $filesize\n" if ($filesize=-s $_) > 1_024_000; } , "/home/ols3" );

蔡逸竹

22. 圖型介面
Perl 和 Tk 搭配，可以產生圖型介面視窗程式喲!

引用:

#! /usr/bin/perl

use Tk;

$m=MainWindow->new;
$m->title("中文標題");

MainLoop;

Figure 1. Perl + Tk 視窗