perl CGI

perl

以下のHTMLファイルは/cgi-binディレクトリにあるCGIプログラムquestionnaire.cgiを呼び出す

<!DOCTYPE HTML PUBLIC "-//W3//DTD HTML 4.0//EN">
<!-- 簡単なアンケートのHTML questionnaire.html-->
<html>
    <head>
        <title>アンケートの例</title>
    </head>

    <body>
        <h1>アンケートの例</h1>

        <p>次の質問にお応えください</p>

        <form action="cgi-bin/questionnaire.cgi" method="post">
            <dl>
                <dt>お名前</dt>
                <dd><input type="text" name="name" value=""></dd>
                <dt>最もよくお使いになっているOS</dt>
                <dd>
                    <ul>
                        <li><input type="radio" name="os"
                                  value="Windows"
                                  checked>Windows</li>
                            <li><input type="radio" name="os"
                                       value="Linux">Linux</li>
                            <li><input type="radio" name ="os"
                                       value="FreeBSD">FreeBSD</li>
                            <li><input type="radio" name ="os"
                                       value="Solaris">Solaris</li>
                            <li><input type="radio" name="os"
                                       value="MacOS">MacOS</li>
                            <li><input type="radio" name="os"
                                       value="Other">その他</li>
                    </ul>
                </dd>
            </dl>
            <p>
                <input type="submit" name="send" value="送信"><br>
                <input type="reset" value="リセット">
            </p>
        </form>
    </body>
</html>

CGIモジュール

#!/usr/bin/perl
#このcgiプログラム・スクリプトはUNIXでは実行権限を与えておく必要がある
#(chmod a+x questionnaire.cgi)

#アンケート処理CGIプログラム・スクリプト
#ユーザーが使っているOSの合計を調べる
#questionnaire.cgi

#モジュール読み込み
use CGI;
$query = new CGI;

#統計ファイルの存在チェック
if(-f "../data/statistic.log"){
    #存在するならファイルをオープンする。失敗したらエラーページを表示
    open(F, "../data/statistic.log")|| &error("ファイル /data/statistic.logをオープン出来ません($!)。\n");
    while(<F>){
        #改行文字を除く
        chomp();
        #名前とOSを取得
        ($name, $os) = split(/\t/);
        #配列@nametotalに名前を蓄積
        push(@nametotal, $name);
        #ハッシュ$ostotalに合計値を蓄積
        $ostotal{$os}++;
    }
    close(F);
}

#アンケートを解析
#名前からタブ文字を取り除く(タブ文字をファイルのでーたの区切りとして使っているため)
$name = $query->param('name');
$name =~ s/\t//g;
#名前に重複がないか解析
foreach(@nametotal){
    if($_ eq $name){
        #等しい物があった時にはエラーページを表示
        &error("お名前 $name はすでに登録されています\n");
    }
}

#変数OSに入っているOS名をキーとする値をインクリメント
$ostotal{$query->param('os')}++;

#記録に追加。失敗したらエラーページを表示
open(F, ">>../data/statistic.log")|| &error("ファイル /data/statistic.logに書き込めません($!)。\n");
print F $name, "\t", $query->param('os'), "\n";
close(F);

#表示 (UNIXではEUC-JPとする)
print $query->header(-charset=>'EUC-JP'),
    $query->start_html(-title=>"現在のアンケート結果");
print "<h2>使用OS</h2>\n";
print "<ul>\n";
#合計数を表示
print "<li><strong>$os</strong>: $count</li>\n" while(($os, $count) = each(%ostotal));
print "</ul>\n";
print $query->end_html();

sub error{
    #エラーページ表示のサブルーチン
    my($message) = @_;

    print $query->header(-charset=>'EUC-JP'),
        $query->start_html(-title=>"エラー");
    print "<h1>エラーが発生しました</h1>\n";
    print $message;
    print $query->end_html();
    #異常終了
    exit(1);
}

初めてのPerl 第6版

初めてのPerl 第6版

perl 簡単なWebブラウザ

perl 
#簡単なWebブラウザ
#browser.pl

#モジュールの使用宣言
use IO::Socket;

#URLを入力
print "URLを指定してください＞";
$url = <STDIN>;

#URLをホスト名とファイルパスに分割
chomp($url);
if($url =~ /http:\/\/([^\/]+)(\/.*)/){
    $host = $1;
    $file = $2;
}else{
    die "そのURLには対応していません。\n";
}

#ソケットオブジェクト作成
$client_socket = new IO::Socket::INET(
    PeerAddr => $host,
    PeerPort => 'http',
    Proto => 'tcp',
    TimeOut => '5'
);
unless($client_socket){
    print "Socket Error:$!\n";
}

#入力をサーバーに送信
print "$host $file" . "\n";
print $client_socket "GET $file HTTP/1.0\n\n";

#出力を取得し、表示(複数行が返ってくるので、取り終わるまで繰り返す)
while($receive = <$client_socket>){
    print $receive;
}

#ソケットを閉じる
$client_socket->close();

#実行結果
# $ perl browser.pl 
# URLを指定してください＞http://cruel.org/
# cruel.org /
# HTTP/1.1 200 OK
# Date: Fri, 08 Jul 2016 07:36:18 GMT
# Server: Apache/2.2.11 (Unix) PHP/5.2.9 mod_ssl/2.2.11 OpenSSL/0.9.8e
# Last-Modified: Wed, 15 Apr 2009 10:28:21 GMT
# ETag: "707c09-24-4679568177b40"
# Accept-Ranges: bytes
# Content-Length: 36
# Connection: close
# Content-Type: text/html; charset=UTF-8

# hello
# </body>
# </html>

初めてのPerl 第6版

初めてのPerl 第6版

perl ソケット

perl

サーバースクリプト

#クライアントからの文字入力を受けてそれをそのまま返すサーバースクリプト
#echoserver.pl

#モジュールの使用宣言
use IO::Socket;

#ソケットオブジェクト作成
$server_socket = new IO::Socket::INET(
    LocalPort => '10000',
    Proto => 'tcp',
    Listen => 5,
    Reuse => 1
);
unless($server_socket){
    print "SOcket Error:$!\n";
}

#待機
$client_socket = $server_socket->accept();

#クライアントからの入力を表示
    while($string = <$client_socket>){
        print "受理：$string";
    }

#ソケットを閉じる
$client_socket->close();
$server_socket->close();

クライアントスクリプト

#文字入力をサーバーに送るクライアントスクリプト
#echoclient.pl

#モジュールの使用宣言
use IO::Socket;

#ソケットオブジェクト作成
$client_socket = new IO::Socket::INET(
    PeerAddr => 'localhost',
    PeerPort => '10000',
    Proto => 'tcp',
    TimeOut => '5'
);
unless($client_socket){
    print "Socket Error:$!\n";
}

#入力をサーバーに送信
while($string = <STDIN>){
    if($string =~ /^QUIT/){
        #QUITという文字列で始まる入力があると終了
        last;
    }
    print $client_socket "$string";
}

#ソケットを閉じる
$client_socket->close();

コマンドプロンプトウインドウを2つ起動し、まずはサーバースクリプトを実行する。
別のコマンドラインからクライアントスクリプトを実行するとこのスクリプトがサーバーに接続される。クライアント側で文字列を入力しenterキーを押すとサーバー側にその文字列が表示される。

実行結果

サーバー側

$ perl echoserver.pl 
受理：from client
受理：hello

クライアント側

$ perl echoclient.pl 
from client
hello
QUIT

初めてのPerl 第6版

初めてのPerl 第6版

perl fork関数

perl 
#forkを使って2つの処理を作る
#fork関数を使って処理を分岐し、親プロセスと子プロセスでそれぞれ異なる文字列表示を実行する
#fork.pl

if($pid = fork()){
    #親プロセス
    for($i = 1; $i <= 3; $i++){
        print "親プロセス\n";
        sleep(3);
    }
    waitpid($pid, 0);
}
elsif(defined $pid){
    #子プロセス
    for($i = 1; $i <= 5; $i++){
        print "子プロセス\n";
        sleep(1);
    }
}else{
    die "fork出来ません:$!\n";
}
#実行結果
# 親プロセス
# 子プロセス
# 子プロセス
# 子プロセス
# 子プロセス
# 親プロセス
# 子プロセス
# 親プロセス

初めてのPerl 第6版

初めてのPerl 第6版

perl 外部プログラムの実行 exec

perl 
#excec関数による実行
#exec.pl

#lsを実行
exec("ls");
print "エラーが発生しました:$!\n";

初めてのPerl 第6版

初めてのPerl 第6版

perl　外部プログラムの実行

perl 
#system関数を使ってunixのlsコマンドを実行する
#shellに関数による実行
#shell.pl

#lsを実行
system("ls");

初めてのPerl 第6版

初めてのPerl 第6版

perl 現在のディレクトリのファイル一覧を表示する

perl 
#現在のディレクトリのファイル一覧を表示する
#ディレクトリの内容を読み込み表示する
#readdir.pl

#現在のディレクトリ(.)をオープンする
opendir(DIR, ".") || die ".をオープンできません：$!\n";

#配列に読み込む
@files = readdir(DIR);

#クローズする
closedir(DIR);

#表示
foreach(@files){
    print "$_\n";
}


#実行結果
# $ ls
# readdir.pl	test1.txt	test2.txt	test3.txt
# $ perl readdir.pl 
# .
# ..
# readdir.pl
# test1.txt
# test2.txt
# test3.txt

初めてのPerl 第6版

初めてのPerl 第6版

perl 指定したディレクトリを削除する

perl 
#指定したディレクトリを削除するスクリプト
#rmdir.pl

print "削除するディレクトリ名を指定してください>";
$directory = <STDIN>;
chomp($directory);

if(-d $directory){
    #ディレクトリがすでにある
    #ディレクトリを削除
    rmdir($directory) || die "$directoryを削除出来ません。:$!\n";
}else{
    #ディレクトリがないかディレクトリではない
    print "$directoryは存在しません。またはディレクトリではありません。\n";
}

#実行結果
# $ perl rmdir.pl 
# 削除するディレクトリ名を指定してください>newDirectory
# $ perl rmdir.pl 
# 削除するディレクトリ名を指定してください>newDirectory
# newDirectoryは存在しません。またはディレクトリではありません。

初めてのPerl 第6版

初めてのPerl 第6版

perl ディレクトリの作成

perl 
#指定したディレクトリが存在するかどうか調べ、存在しない時は新しく作成する
#指定したディレクトリを作成
#mkdir.pl

print "作成するディレクトリ名を指定してください>";
$directory = <STDIN>;
chomp($directory);

if(!-d $directory){
    #ディレクトリがまだない
    #ディレクトリを作成
    mkdir($directory, 0755) || die "$directoryを作成できません:$!\n";
}else{
    #既に存在
    print "$directoryは既に存在します。\n";
}

#実行結果
# $ perl mkdir.pl
# 作成するディレクトリ名を指定してください>newDirectory
# $ perl mkdir.pl 
# 作成するディレクトリ名を指定してください>newDirectory
# newDirectoryは既に存在します。

初めてのPerl 第6版

初めてのPerl 第6版

perl ファイルの削除時にY/Nで確認する

perl 
#ファイル名を引数として受け取り、ファイルの有無を確認した後、
# 「＜ファイル名＞を削除しますか？(Y/N):」というメッセージを出して、Yが押された時のみファイルを削除するスクリプト

#ファイルの削除時に確認する
#remove_ask.pl

$filename = $ARGV[0];

if(-f $filename){
    while(){
        print "$filenameを削除しますか？(Y/N):";
        $answer = <STDIN>;
        chomp($answer);

        if($answer eq 'Y'){
            unlink($filename) or die "$filenameは削除できませんでした:$!\n";
            last;
        }elsif($answer eq 'N'){
            last;
        }else{
            print "無効な値が入力されました。\n";
        }
    }
}else{
    print "$filenameは存在しません。\n";
}


#実行結果
# $ perl remove_ask.pl  output.txt
# output.txtを削除しますか？(Y/N):y
# 無効な値が入力されました。
# output.txtを削除しますか？(Y/N):n
# 無効な値が入力されました。
# output.txtを削除しますか？(Y/N):Y

初めてのPerl 第6版

初めてのPerl 第6版

perl 既存のファイルに権限を追加する

perl 
#指定した引数をファイル名として扱い、そのファイルの所有者がユーザ自信であり、読み込み権限を持っていれば、既存の権限に加えて所有者とグループの書込権限を付けるスクリプト

#既存のファイルに権限を追加する
#append_mod.pl

if(@ARGV > 0){
    if(-o $ARGV[0]){
        #所有者のファイルかどうか調べる

        #ファイル情報を取得
        ($device, $inode, $mode, $nlink, $userid, $groupid, $rdev, $size, $accesstime, $modifytime, $changetime, $blocksize, $blockcount) = stat($ARGV[0]);

        #権限を追加
        chmod($mode | 0220, $ARGV[0]);
    }else{
        print "所有のファイルではありません\n";
    }
}else{
    print "ファイル名を指定してください\n";
}

初めてのPerl 第6版

初めてのPerl 第6版

perl　statでファイルの詳細な情報を表示する

perl 
#指定したファイルの詳細な情報を表示する
#stat.pl

print "ファイル名を指定してください>";
$file = <STDIN>;
chomp($file);

#statで情報を取得
($device, $inode, $mode, $nlink, $userid, $groupid, $rdev, $size, $accesstime, $modifytime, $changetime, $blocksize, $blockcount) = stat($file);

#各情報を表示
printf("デバイス:%d\n".
       "i-node: %d\n".
       "権限値: %o\n".
       "リンク:%d\n".
       "ユーザID: %d\n".
       "グループID:%d\n".
       "デバイス識別子:%d\n".
       "サイズ:%d\n".
       "アクセス時間:%d\n".
       "更新時間:%d\n".
       "i-node変更時間:%d\n".
       "ブロックサイズ:%d\n".
       "ブロック数:%d\n",
       $device, $inode, $mode, $nlink, $userid, $groupid, $rdev, $size, $accesstime, $modifytime, $changetime, $blocksize, $blockcount
   );

#実行結果
# デバイス:16777222
# i-node: 820392
# 権限値: 100700
# リンク:1
# ユーザID: 501
# グループID:20
# デバイス識別子:0
# サイズ:0
# アクセス時間:1467785883
# 更新時間:1467736439
# i-node変更時間:1467787740
# ブロックサイズ:4096
# ブロック数:0

初めてのPerl 第6版

初めてのPerl 第6版

perl chmod関数で権限を変更する

perl 
#chmod関数を使って指定したファイルの読み込み、書込、実行権限をそれぞれ変更する

#ファイル権限の変更
#chmod.pl

print "ファイル名を指定してください＞";
$file = <STDIN>;
chomp($file);

#初期状態を表示
print "初期状態:\n";
&fileinfo();

print "権限値を100にします\n";
chmod(0100, $file);
&fileinfo();

print "権限値を200にします。\n";
chmod(0200, $file);
&fileinfo();

print "権限値を400にします。\n";
chmod(0400, $file);
&fileinfo();

print "権限値を600にします。\n";
chmod(0600, $file);
&fileinfo();

print "権限値を700にします。\n";
chmod(0700, $file);
&fileinfo();

sub fileinfo{
    #ファイルの情報を表示
    print "\t$fileは読み込めます\n" if (-r $file);
    print "\t$fileは書き込めます\n" if (-w $file);
    print "\t$fileは実行できます\n" if (-x $file);
}

#実行結果
# ファイル名を指定してください＞output.txt
# 初期状態:
# 	output.txtは読み込めます
# 	output.txtは書き込めます
# 権限値を100にします
# 	output.txtは実行できます
# 権限値を200にします。
# 	output.txtは書き込めます
# 権限値を400にします。
# 	output.txtは読み込めます
# 権限値を600にします。
# 	output.txtは読み込めます
# 	output.txtは書き込めます
# 権限値を700にします。
# 	output.txtは読み込めます
# 	output.txtは書き込めます
# 	output.txtは実行できます

初めてのPerl 第6版

初めてのPerl 第6版

perl ファイルの情報を調べる

perl 
#引数をファイル名とみなして、各情報を調べる
#ファイルのテスト
#filetest.pl

if(@ARGV > 0){
    #最初の引数をファイル名とみなす
    print "$ARGV[0] は通常のファイルです\n" if(-e $ARGV[0]);
    print "$ARGV[0] はディレクトリです。\n" if(-d $ARGV[0]);
    print "$ARGV[0] はシンボリックリンクです\n" if(-l $ARGV[0]);
    print "$ARGV[0] はあなたが所有者です。\n" if(-o $ARGV[0]);
    print "$ARGV[0] は名前付きパイプです\n" if(-p $ARGV[0]);
    print "$ARGV[0] は読み込めます。\n" if(-r $ARGV[0]);
    print "$ARGV[0] は書き込めます。\n" if(-w $ARGV[0]);
    print "$ARGV[0] は実行できます。\n" if(-x $ARGV[0]);
    print "$ARGV[0] はバイナリファイルです。\n" if(-B $ARGV[0]);
    print "$ARGV[0] はテキストファイルです。\n" if(-T $ARGV[0]);
    print "$ARGV[0] はソケットファイルです。\n" if(-S $ARGV[0]);
}else{
    print "ファイル名を指定してください\n";
}

#実行結果
# $ perl filetest.pl output.txt
# output.txt は通常のファイルです
# output.txt はあなたが所有者です。
# output.txt は読み込めます。
# output.txt は書き込めます。
# output.txt はバイナリファイルです。
# output.txt はテキストファイルです。

初めてのPerl 第6版

初めてのPerl 第6版

perl 指定したファイルを削除する

perl 
#指定したファイルを削除する
#unlink.pl

$file = <STDIN>;
chomp($file);
unlink($file) || die "$fileを削除できません:$!\n";

#実行結果
# $ perl unlink.pl 
# testtesttesttxt

初めてのPerl 第6版

初めてのPerl 第6版