#!/usr/bin/perl # ================================================================ # マルチアンケートスクリプト # Multi Unit Locate Technology Interface「マルチ」 Ver1.05 # 2002.04.19　ダダ # http://sygnas.tv/ # ================================================================ # # ・このスクリプトは「“シェー”ウェア」です。継続して使用するには # “シェー”に関する画像や情報をメールなどで送ってください。 # “シェー”とはもちろんフランス帰国野郎のアレです。:-) # ばーい赤塚不二夫。 # # ・単ページはもちろん、複数ページに渡る質問も対応しています。 # ・単ページの場合は必ず # を記述 # ・複数ページの場合は、、、 # を記述しないでください。サンプルファイルを参照。 # ・複数ページの時、$FILE_HEAD を指定しておくと楽チンです。 # ・スクリプト他の記述は EUCですが、集計ファイルは SJISです（何故）。 # ・月が変わってから書き込みを行うと、過去の月を１ファイルにまとめます。 # ・$FILE_END で ./makoto.cgi を指定するとリアルタイムで # 結果をユーザーに見せることができます。 # ・このソースはタブ幅「4」で最適化されています。 # ・横幅は画面いっぱいで。:-) # ・スクリプトの略称にはツッこまないように。 # # ================================================================ # NAME="Qn" 質問項目の NAME属性。nは数字 # NAME="nm_x" エラーで表示する項目名。xは↑のNAME。質問項目全部に付ける。 # NAME="next" 次に読み込むページのファイル名。最後のページなら「LAST」 # NAME="items" アンケート項目として読み込むアイテム一覧。 # NAME="hissu" 必須入力項目 # NAME="limit" 複数選択での選択制限。「Q22<2」で「Q22は2個以内」 # NAME="connect"関連項目を指定（「～を～にした方は～も記入してください」とか） # ================================================================ # ■記述例 # 好きな動物 → # # # # # # # ---------------------------------------------------------------- # Q1、Q3が必須記入で、Q2は「2個以上」、Q3は「4個以内」。 # Q2で「飼っている」と答えた人は Q3にも記入する必要があるという意味。 # ================================================================ # 注意：複数選択を格納する際「,」を使っているので、回答語の中に # 「,」は含めないようにしてください。 # 注意：↑と同じ理由で項目名にも「,」を入れないでください。 # 注意：NAME="answer"、NAME="header" は複数ページ回答引き継ぎで使用。 # 注意：このスクリプトを含め、アンケートフォームなど全てのファイルは # EUCで記述してください。 # ================================================================ # 初期設定 # ================================================================ # 必須：設置環境 # -------------------------------------- require './jcode.pl'; # jcode.plの場所 require './dada2.pl'; # ダダ用 CGIライブラリの場所 $CGI_ME = './multi.cgi'; #このスクリプトのＵＲＬ $DIR_RES = './data/'; # データ保存ディレクトリ $FILE_1ST = './form1.dat'; # 最初に表示するページ（単ページなら不要） #$FILE_END = 'makoto.cgi'; # 入力完了画面。「http」で始まる場合URLジャンプ #$FILE_END = 'form_thanks.dat'; $FILE_END = 'http://www.eyescream.jp/special/enq/thank.html'; $FILE_HEAD = './form_head.dat'; # HTMLのヘッダ（単ページなら不要） $FILE_FOOT = './form_foot.dat'; # HTMLのフッタ（単ページなら不要） # 任意：表示関係（そのままでもいいです） # -------------------------------------- $COL_ERR = '#cc0000'; # エラー表示の項目強調色 $ht_title = 'EYESCREAMユーザーアンケート'; # ページタイトル $ht_code = 'euc-jp'; # ページの文字コード（変更不可） $ht_body = ''; $ht_style = ''; # 任意：動作設定（そのままでもいいです） # -------------------------------------- $DATA_EXT = 'dat'; # 集計データの拡張子 $ADD_HEAD = 1; # 集計ファイルに項目ヘッダ付加（yes=[1] / no=0） $ADD_PROC = 0; # 日付フィールドにプロセス番号追加（yes=1 / no=[0]） $CHK_DEL = 1; # 過去月結合後、オリジナル削除（yes=[1] / no=0） $CHK_LOW = 0; # 英数字の全角→半角変換（yes=1 / no=[0]） $CHK_EMAIL = 1; # メールアドレスの書式をチェック（yes=[1] / no=0） $CHK_LAST = 0; # データ登録前に確認ページを表示（yes=1 / no=[0]） $CHK_URL = 0; # urlの書式をチェック（yes=[1] / no=0） # NAME="email"、NAME="url"に限定 $CHK_CNT = 0; # NAME="connect"の指定先が入力されてるのに元が入力 # されていない場合、自動的に補完（yes=1 / no=[0]） $HANKAKU = '0-9A-Za-z!”#$%&’()=|@[]{}<>?+*/\@-'; # 全角→半角変換するもの $ZENKAKU = '０-９Ａ-Ｚａ-ｚ！”＃＄％＆’（）＝｜＠［］｛｝＜＞？＋＊／￥＠－'; $FILE_LOCK = $DIR_RES.'lock.txt'; # ファイルロック用 # ================================================================ # メイン # ================================================================ &dada::form_decode('euc'); &conv_answer; # アンケートをコンバート if( $FORM{next} eq 'LAST' ){ # 登録 if( $CHK_LAST && !$FORM{chk_last} ){ &chk_last; exit;} # 最終確認 &input; # 集計出力 &mounth_total; # 過去の月をまとめる if( $FILE_END =~ /^http/ || $FILE_END =~ /makoto.cgi/){ # 終了後の表示ページ print "Location:".$FILE_END."\n\n"; }else{ &ht_head; open( IN,$FILE_END ); while( ){ print; } close( IN ); &ht_foot; } }else{ # フォーム表示 if( $FORM{next} eq '' ){ $FORM{next} = $FILE_1ST; } &ht_head; print "

\n"; open( IN,$FORM{next} ); while( ){ print; } close( IN ); print "\n"; print "\n"; print "\n"; &ht_foot; } exit; # ================================================================ # アンケートコンバート # ================================================================ sub conv_answer{ my $msg; # エラー文格納用 # 不足項目のチェック # ----------------------------------------------- $badpoint = ''; foreach $i ( split( /,/,$FORM{'hissu'} ) ){ if( $FORM{$i} eq '' ){ $badpoint .= "【$FORM{'nm_'.$i}】" } } if( $badpoint ){ $msg ="$badpointが入力されていません。

"; $msg .= '

ご使用のブラウザの「戻る」ボタンで前のページに戻ってやり直してください。

'; &ht_error( $msg ); } # チェックボックスの制限チェック # ----------------------------------------------- $badpoint = ''; foreach $i ( split( /,/,$FORM{'limit'} ) ){ $i =~ /^(.+)([<>])(\d+)$/; @limit_count = split( /,/,$FORM{$1} ); if( $2 eq '<' && $3 < @limit_count ){ $badpoint .= "【$FORM{'nm_'.$1}】は$3個まで"; }elsif( $2 eq '>' && $3 > @limit_count ){ $badpoint .= "【$FORM{'nm_'.$1}】は$3個以上必要"; } } if( $badpoint ){ $msg ="$badpointです。

"; $msg .= '

ご使用のブラウザの「戻る」ボタンで前のページに戻ってやり直してください。

'; &ht_error( $msg ); } # 関連項目のチェック（3番で「はい」の方は記入してください～とかいうやつのチェック） # ----------------------------------------------- $badpoint = ''; my $cnt_p1,$cnt_wd,$cnt_p2; foreach $i ( split( /,/,$FORM{'connect'} ) ){ $i =~ /^(.+)>(.+)>(.+)$/; $cnt_p1 = $1; $cnt_wd = $2; $cnt_p2 = $3; if( $FORM{$cnt_p1} =~ /$cnt_wd/ && !$FORM{$cnt_p2} ){ $badpoint .= "【$FORM{'nm_'.$cnt_p1}】を「$cnt_wd」にした方は"; $badpoint .= "【$FORM{'nm_'.$cnt_p2}】にも記入お願いします。
\n"; } # ↓関連先が入力されてるのに元が入力されてない場合、補完する if( $FORM{$cnt_p2} && $FORM{$cnt_p1} !~ /$cnt_wd/ && $CHK_CNT ){ $FORM{$cnt_p1} .= ',' if exists $FORM{$cnt_p1}; $FORM{$cnt_p1} .= $cnt_wd; } } &ht_error( $badpoint ) if $badpoint; # メールアドレスの書式チェック # ----------------------------------------------- if( $FORM{email} && $CHK_EMAIL && &chk_email( $FORM{email} ) ){ $msg ="メールアドレスの書式が違います

"; $msg .= '

ご使用のブラウザの「戻る」ボタンで前のページに戻ってやり直してください。

'; &ht_error( $msg ); } # URLの書式チェック # ----------------------------------------------- if( $FORM{url} && $CHK_URL && &chk_url( $FORM{url} ) ){ $msg ="URLの書式が違います

"; $msg .= '

ご使用のブラウザの「戻る」ボタンで前のページに戻ってやり直してください。

'; &ht_error( $msg ); } # コンバート # ----------------------------------------------- $FORM{zip1} .= "-$FORM{zip2}"; @form_items = split( /,/,$FORM{items} ); foreach $i ( @form_items ){ $FORM{$i} =~ s/&/&/g; $FORM{$i} =~ s//>/g; $FORM{answer} .= "$FORM{$i}%%%%"; $FORM{header} .= "$FORM{'nm_'.$i}%%%%"; } &jcode::tr( \$FORM{answer},$ZENKAKU,$HANKAKU ) if $CHK_LOW; # 半角変換 $badpoint = ''; } # ================================================================ # 入力 # ================================================================ sub input{ my $add_head_go; # 集計ファイルヘッダ付加判定 my $head_plus = "入力時刻,ブラウザ\tホスト"; # ヘッダに必ず付けるもの %T = (); ### 時間を格納 ■Ver1.05 # ユーザー情報取得 # ----------------------------------------------- $USER{browser} = $ENV{'HTTP_USER_AGENT'}; $USER{host} = &get_host; # データ書き出し # ----------------------------------------------- ### ■Ver1.05 %T = &get_time; # 出力ファイルは「yyyymmdd.$DATA_EXT」 $TIME_NOW = sprintf( "$T{year}/%02d/%02d-%02d:%02d:%02d",$T{mon},$T{mday},$T{hour},$T{min},$T{sec} ); $FILE_RES = $DIR_RES . sprintf( "$T{year}%02d%02d.$DATA_EXT",$T{mon},$T{mday} ); $TIME_NOW = $TIME_NOW . "-$$" if $ADD_PROC; # 日付にプロセス番号追加して一意にする $FORM{answer} =~ s/%%%%/\t/g; $FORM{header} =~ s/%%%%/\t/g; &jcode::euc2sjis( \$FORM{answer} ); &jcode::euc2sjis( \$FORM{header} ); &lock1; # ロック if( !-f $FILE_RES ){ $add_head_go = 1; } open( OUT,">>".$FILE_RES ); # ヘッダ付加 # ----------------------------------------------- if( $add_head_go && $ADD_HEAD ){ # 初めての書き込みではヘッダ付加する &jcode::euc2sjis( \$head_plus ); $head_plus =~ /^(.+),(.+)$/; print OUT "\%HEAD\%$1\t". $FORM{header} . $2 ."\n"; } print OUT $TIME_NOW ."\t". $FORM{answer} . $USER{browser} ."\t". $USER{host} . "\n"; close( OUT ); chmod( 0666,$FILE_RES ); if (-e $FILE_LOCK) { unlink($FILE_LOCK); } # ロック解除 } # ================================================================ # 過去月のファイルをまとめる # ================================================================ sub mounth_total{ my $file_data; # データファイル %total_head = (); # ヘッダ %total_value = (); # 月毎のまとめ my $now = sprintf( "$T{year}%02d", $T{mon} ); ### 現在の月 ■Ver1.05 # とりあえず月ごとにまとめる # ----------------------------------------------- opendir( DIR,$DIR_RES ); while( $file_data = readdir( DIR ) ){ if( $file_data =~ /^(\d\d\d\d)(\d\d)\d\d\.$DATA_EXT$/i ){ $file_mounth = $1.$2; ### ■Ver1.05 if( $now > $file_mounth ){ # 現在の月より古ければ実行 ■Ver1.05 open( DATA,$DIR_RES.$file_data ); while( ){ if( /^\%HEAD\%/ && not exists $total_head{$file_mounth}){ $total_head{$file_mounth} = $_; }elsif( !/^\%HEAD\%/ && !/^\n$/){ $total_value{$file_mounth} .= $_; } } close( DATA ); unlink( $DIR_RES.$file_data ) if $CHK_DEL; # オリジナルを削除 } } } closedir( DIR ); # イッキに書き出し # ----------------------------------------------- my $tmp_value; foreach( keys %total_value ){ open( TOTAL,'>>'."$DIR_RES$_.$DATA_EXT" ); print TOTAL $total_head{$_}; # 日付順にソートして書き込み foreach $tmp_value ( sort split( /\n/,$total_value{$_} ) ){ print TOTAL $tmp_value."\n"; } close( TOTAL ); chmod( 0666,"$DIR_RES$_.$DATA_EXT" ); } } # ================================================================ # 最終確認 # ================================================================ sub chk_last{ &ht_head; print <<"EOM";

データ登録をします。回答内容は以下でよろしいでしょうか。
問題なければを押してください。

EOM my $i; @tmp_answers = split( /\%\%\%\%/,$FORM{answer} ); @tmp_headers = split( /\%\%\%\%/,$FORM{header} ); foreach $i ( 0 .. @tmp_headers -1 ){ if( $tmp_headers[$i] ) { print ""; } else { print ""; } print "\n"; } print <<"EOM";

$tmp_headers[$i]
問$i	$tmp_answers[$i]

EOM &ht_foot; } # ==================================================================== # ロックファイル（symlink関数） # ==================================================================== sub lock1 { my $retry = 5; my $msg; while (!symlink(".", $FILE_LOCK)) { if (--$retry <= 0) { $msg = "現在大変混み合っております。申し訳ありませんが、しばらくしてから再度お試しください。"; &ht_error( $msg ); } sleep(1); } } # ================================================================ # htmlヘッダ # ================================================================ sub ht_head(){ &dada::ht_head; open( IN,$FILE_HEAD ); while( ){ print; } close( IN ); } # ================================================================ # htmlフッタ # ================================================================ sub ht_foot(){ open( IN,$FILE_FOOT ); while( ){ print; } close( IN ); &dada::ht_foot; } # ================================================================ # エラー文 # ================================================================ sub ht_error{ &ht_head(); print "

$_[0]

\n"; &ht_foot(); exit; } # ================================================================ # メールアドレスの書式チェック # OHZAKI Hiroki氏の「Perlメモより」http://www.din.or.jp/~ohzaki/perl.htm#Mail # ================================================================ sub chk_email{ my $email = $_[0]; my $esc = '\\\\'; my $Period = '\.'; my $space = '\040'; my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]'; my $OpenParen = '$'; my $CloseParen = '$'; my $NonASCII = '\x80-\xff'; my $ctrl = '\000-\037'; my $CRlist = '\n\015'; my $qtext = qq/[^$esc$NonASCII$CRlist\"]/; my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; my $quoted_pair = qq<${esc}[^$NonASCII]>; my $ctext = qq<[^$esc$NonASCII$CRlist()]>; my $Cnested = qq<$OpenParen$ctext*(?:$quoted_pair$ctext*)*$CloseParen>; my $comment = qq<$OpenParen$ctext*(?:(?:$quoted_pair|$Cnested)$ctext*)*$CloseParen>; my $X = qq<[$space$tab]*(?:${comment}[$space$tab]*)*>; my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; my $atom = qq<$atom_char+(?!$atom_char)>; my $quoted_str = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">; my $word = qq<(?:$atom|$quoted_str)>; my $domain_ref = $atom; my $domain_lit = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>; my $sub_domain = qq<(?:$domain_ref|$domain_lit)$X>; my $domain = qq<$sub_domain(?:$Period$X$sub_domain)*>; my $route = qq<\@$X$domain(?:,$X\@$X$domain)*:$X>; my $local_part = qq<$word$X(?:$Period$X$word$X)*>; my $addr_spec = qq<$local_part\@$X$domain>; my $route_addr = qq[<$X(?:$route)?$addr_spec>]; my $phrase_ctrl = '\000-\010\012-\037'; my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; my $phrase = qq<$word$phrase_char*(?:(?:$comment|$quoted_str)$phrase_char*)*>; my $mailbox = qq<$X(?:$addr_spec|$phrase$route_addr)>; if( $email =~ /^$mailbox$/o ) { return "0"; } else { return "1"; } } # ================================================================ # URLの書式チェック # OHZAKI Hiroki氏の「Perlメモより」http://www.din.or.jp/~ohzaki/perl.htm#httpURL # ================================================================ sub chk_url{ my $url = $_[0]; if( $url =~ /^s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:@&=+$,%#]+$/ ) { return "0"; } else { return "1"; } } # ==================================================================== # ホスト名取得 # ==================================================================== sub get_host { my $gt_host = $ENV{'REMOTE_HOST'}; my $gt_addr = $ENV{'REMOTE_ADDR'}; if( $gt_host eq "" || $gt_host eq "$gt_addr" ) { my( $p1,$p2,$p3,$p4 ) = split( /\./,$gt_addr ); my $temp = pack( "C4",$p1,$p2,$p3,$p4 ); $gt_host = gethostbyaddr( $temp,2 ); } if( $gt_host eq "" ){ $gt_host = $gt_addr; } return $gt_host; } # 日付の取得 ■Ver1.05 # =============================================================================== sub get_time { my %T; $ENV{'TZ'} = "JST-9"; ( $T{sec},$T{min},$T{hour},$T{mday},$T{mon},$T{year},$T{wday},$T{yday},$T{isdst} ) = ( localtime(time + $_[0]) ); $T{mon}++; $T{year} += 1900; return %T; }