TSperl 発言

作者: dune
日時: 2002/5/22(01:54)
極悪です。

おもしろい話題があれば書きたいのですが なかなか ないので、
つまらないものばっかですが 手元にあるスクリプトを少しずつ
アップしてみようかと思います。

# そういや、この前 Kansai.pm に行きました。じゃんけん大会で
# 文字コード表をもらって、帰りに中島靖さんにサインしてもらい
# ました。中島さんは見かけは怖いがしゃべるとおもしろい上岡龍
# 太郎のような方でした。川合孝典さんは河合俊一のような人を想
# 像してたのですが、実際はきっぷのいい、うまいもん食ってると
# きが幸せ、みたいな方でした。

まずは [TSfree:189] で書いたアンケート CGI です。まだフォー
ムが出るだけで結果の保存・集計部分はありません。
http://hpcgi1.nifty.com/dune/tsna.pl で動いてるものです。

アドバイスとか、これはオカシイ、ってのがあればよろしく。
＃ チェックボックスの処理がバグってますが、どう解決するか決
＃ めてない。

動作は、HashDB/TSNA.hdb というファイルを読んでアンケートフォ
ームを作成するようになってます($rx=0)。フォームデータを受け
取ったときも同じスクリプトで処理します($rx=1)。

アンケートフォーム自体はスタティックな HTML にすべきなのです
が、そこは僕の趣味で CGI にしてます。while の中は IDLE と   
TABLE の二つの状態からなるステートマシンになってます。



--^ CGI.pm
package GLilac::CGI;

#use strict;
#no warnings qw(uninitialized);
use Exporter;
use vars qw($VERSION @ISA @EXPORT);
($VERSION) = q($Revision: 1.25 $) =~ m/\s([\d.]+)\s/;   

@ISA        = qw(Exporter);
@EXPORT     = qw(
    win32msgbox
    getform     getcookie
    uri_escape  uri_unescape
    chr_escape  chr_unescape
    lock        unlock
    time2str
);;;

sub  win32msgbox{
    return unless defined $ENV{windir};
    return if $ENV{NOTWIN32};
    eval q<
        use Win32;
        my($msg,$cnt);
        foreach(@_){
            ++$cnt;
            $msg .= qq($cnt："$_"\n);
        }
        Win32::MsgBox($msg);
    >;
}

sub getform{
    my $method = $ENV{REQUEST_METHOD};
    return unless defined $method;

    my %form;

    $method =~ tr/a-z/A-Z/;
    my $query;
    if($method eq 'POST'){
        my $a = $ENV{CONTENT_LENGTH};
        my $b = read(STDIN,$query,$a);
        $form{-deltapost} = $a - $b if $a != $b;
    }else{
        $query = $ENV{QUERY_STRING};
    }

    win32msgbox $query;

    ($query,$form{-refer}) = split(m/[&?]-refer=/,$query,2);
    foreach(split(m/[&?]/,$query)){
        my($key,$val) = split m/=/;
        $form{$key} = qq($val);
    }
    return %form;
}

sub getcookie{
    my %ck;
    foreach(split(m/;\s/,$ENV{HTTP_COOKIE}.'')){    # !typo
        my($key,$val) = split m/=/;
        $ck{$key} = qq($val);
    }
    return %ck;
}

sub uri_escape{
    local $_ = shift or return;
    s/(\W)/sprintf("%%%02X",ord($1))/eg;
#   s/(\W)/'%'.unpack('H2',$1)//eg;
    return $_;
}

sub uri_unescape{
    local $_ = shift or return;
    tr/+/ /;
    s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
#   s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2',$1)/eg;
    return $_;
}

sub chr_escape{
    local $_ = shift;
    s/&/&amp;/go;
    s/"/&quot;/go;
    s/</&lt;/go;
    s/>/&gt;/go;
    # s/\x20/&nbsp;/go;
    return $_;
}

sub chr_unescape{
    local $_ = shift;
    s/&amp;/&/go;
    s/&quot;/"/go;
    s/&lt;/</go;
    s/&gt;/>/go;
    s/&nbsp;/\x20/go;
    return $_;
}

# 中略

1;;;
__END__
--$



--^ tsna.pl
#!/usr/local/bin/perl -I./lib
use strict;
use GLilac::CGI;

BEGIN{  print qq(Content-type: text/html; charset=SHIFT-JIS\x0D\x0A\x0D\x0A)    }



my %form    = getform;
my $rx      = 1 < %form ? 1 : 0;

my $title   = $rx ? q(アンケート回答) : q(アンケートフォーム);
my $style   = qq(http://homepage1.nifty.com/dune/css/gokuaku.css);
#$style = qq(http://localhost/css/gokuaku.css);
my $header  = qq{
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<HTML lang="ja">
<HEAD>
<META http-equiv="Content-Type" content="text/html; charset=SHIFT_JIS">
<TITLE>$title</TITLE>
<LINK rev="Made" href="mailto:FZH01112\@nifty.ne.jp">
<META http-equiv="Content-Style-Type" content="text/css">
<LINK rel="Stylesheet" type="text/css" href="$style">
<META name="ROBOTS" content="NOINDEX,NOFOLLOW">
</HEAD>
};



sub do_area{
    my($id,$item)   = @_;
    my $body;
    if($rx){
        $body   .= chr_escape uri_unescape $form{$id} || q(無回答);
        $body   =~ s/\n+/<BR>\n/g;
    }else{
        $body   .= qq(<TEXTAREA cols=30 rows=8 wrap=hard name=$id>$item</TEXTAREA>\n);
    }
    return $body;
}



sub do_text{
    my($id,$item)   = @_;
    my $body;
    if($rx){
        $body   .= chr_escape uri_unescape $form{$id} || q(無回答);
    }else{
        $body   .= qq(<INPUT type=text size=40 name=$id value="$item">\n);
    }
    return $body;
}



sub do_radio{
    my($id,$item)   = @_;
    my $body;
    if($rx){
        my $ans = uri_unescape $form{$id};
        $body   .= $ans eq "その他" ? chr_escape uri_unescape $form{"$id-else"} :
                                             $ans || q(無回答);
    }else{
        foreach(split(m/\s+/,$item)){
            $body   .= qq(<INPUT type=radio name=$id value="$_">$_\n);
        }
        $body   .= qq(<BR>\n);
        $body   .= qq(<INPUT type=radio name=$id value="その他">\n);
        $body   .= qq(<INPUT type=text size=30 name="$id-else" value="その他">\n);
    }
    return $body;
}



sub do_check{
    my($id,$item)   = @_;
    my $body;
    if($rx){
        my $ans = uri_unescape $form{$id};
        $body   .= $ans eq "その他" ? chr_escape uri_unescape $form{"$id-else"} :
                                             $ans || q(無回答);
    }else{
        foreach(split(m/\s+/,$item)){
            $body   .= qq(<INPUT type=checkbox name=$id value="$_">$_\n);
        }
        $body   .= qq(<BR>\n);
        $body   .= qq(<INPUT type=checkbox name=$id value="その他">\n);
        $body   .= qq(<INPUT type=text size=30 name="$id-else" value="その他">\n);
    }
    return $body;
}



my $action_cgi  = q(tsna.pl);
my $data        = "HashDB/TSNA.hdb";
my $state       = 'IDLE';
my $body        = qq(<BODY>\n<H1>$title</H1>\n);
my $table       = qq(<TABLE summary="アンケート項目">\n);
$table          .= qq(<COL width=30 align=center><COL width=140><COL width=240>\n);

my $no  = 0;
$body   .= qq(<FORM method=POST action="$action_cgi">\n);
open(FILE,$data) or die $!;
while(<FILE>){
    next if index($_,"#") == 0;
    s/[\s\r\n]+$//;
    next unless length;
    $_  = chr_escape $_;
    s/\x00.+//;

    if(m/^■(.+)$/){
        if($state eq 'TABLE'){
            $body   .= qq(</TABLE>\n);
            $state  = 'IDLE';
        }
        $body   .= qq(<H2>$1</H2>\n);
        next;
    }

    if(m/^,(\S.+)\s*,\s*(TEXT|CHECK|RADIO|AREA)\s*,\s*(.*)$/){
        if($state ne 'TABLE'){
            $body   .= $table;
            $state  = 'TABLE';
        }
        ++$no;
        $body   .= qq(<TR>\n<TD>$no.</TD><TD>$1</TD>\n<TD>\n);
        $body   .=  ($2 eq 'TEXT')  ? do_text($no,$3)   :
                    ($2 eq 'CHECK') ? do_check($no,$3)  :
                    ($2 eq 'RADIO') ? do_radio($no,$3)  :
                    ($2 eq 'AREA')  ? do_area($no,$3)   :
                    die                                     ;;;
        $body   .= qq(</TD>\n</TR>\n);
        next;
    }

    if($state eq 'TABLE'){
        $body   .= qq(</TABLE>\n);
        $state  = 'IDLE';
    }
    $body   .=  qq(<P>$_</P>\n);
}

if($state eq 'TABLE'){
    $body   .= qq(</TABLE>\n);
    $state  = 'IDLE';
}

if($rx){
    $body   .= qq(<P>ありがとうございました。</P>\n);
}else{
    $body   .= qq(<INPUT type=submit value=" 送信 ">\n);
}

$body   .= qq(</FORM>\n</BODY>\n</HTML>\n);



print $header,$body;
close FILE;

#open(FILE,">D:/Desktop/gomi.htm") or die;
#print FILE $header,$body;
#close FILE;

__END__
--$



--^ TSNA.hdb
そのまんま表示
,名前,TEXT,
,性別,RADIO,男性 女性
,言語,CHECK,日本語 英語 
,ご意見,AREA,
--$
-- 
FZH01112@..., http://www1.u-netsurf.ne.jp/~dune/
前の発言:
63. Re: Let's野ぷ野ぷ（その４）〜順列 [dune] 2002/5/22(01:54)
後の発言:
65. Re: Let's野ぷ野ぷ（その５）〜アンケートCGI [KAWAI,Takanori] 2002/5/22(23:16)
親発言:
子発言:
65. Re: Let's野ぷ野ぷ（その５）〜アンケートCGI [KAWAI,Takanori] 2002/5/22(23:16)
　　　　