簡易ＢＢＳ（ＣＧＩ用）

１行タイプの簡易ＢＢＳプログラムです。
この HTML 上では漢字がシフトJIS になっていますが、本来は EUC 向けとなっています。
@Nifty向けにパス名などが設定されています。また、同様の理由で組み込み以外のライブラリを必要としません。
フォームのデコードも自前で行なっています。 

#!/usr/local/bin/perl

# IE/その他判別
$IE = ( $ENV{'HTTP_USER_AGENT'} =~ /MSIE/i );

$cgi_path = "";
$cgi_file = "http://hpcgi2.nifty.com/caty/testbbs.cgi";
$datafile = "dfile";
$max_url = 80;
$max_name = 24;
$max_text = 128;
if ($IE) {
    $ftext_size = 128;
} else {
    $ftext_size = 100;
}
$record_size = 256;
$record_top = 1;
$record_max = 255;


read(STDIN, $bf, $ENV{'CONTENT_LENGTH'} );
%FORM = &form_decode($bf);

&pr_header;

pr_form(0);

$err = 0;
$data_ptr = 1;
$data_num = 0;
$top_rec = "";

### file open & initialize ###
if (!open(DATAFILE, "+< $datafile")) {
# オープンできない場合新規作成とみなす
    unlink "$datafile";
    if (!open(DATAFILE, "> $datafile")) {
# どうにもならない
	$err = 1;
    } else {
	close(DATAFILE);
	if (!open(DATAFILE, "+< $datafile")) {
	    $err = 1;
	} else {
# 新規作成処理
	    binmode(DATAFILE);   # 一応入れておく
	    flock(DATAFILE,2);
	    &set_dataptr;
	}
    }
} else {
    binmode(DATAFILE);   # 一応入れておく
    flock(DATAFILE,1);
    seek(DATAFILE, 0, 0);
    if (read(DATAFILE, $top_rec, $record_size) == $record_size) {
	($data_ptr, $data_num) = split(/:/, $top_rec, 2);
##	print $data_ptr, " ", $data_num, "<BR>";
    } else {
	$err = 1;
    }
}

if ($err == 0) {
# file open 成功時のみ
    if ($ENV{'REQUEST_METHOD'} =~/POST/i && length($FORM{'text'})>0) {
	# text 未入力でPOST動作の場合は投稿を無効とする
	&post_msg;
    } else {
	&disp_msg;
    }
} else {
    print "サーバー側の異常でファイルが開けませんでした。<BR>";
}
close(DATAFILE);

&pr_footer;

#--------------- main end ---------------

########## html Header/Footer 出力 ##########
sub pr_header {
    print <<Multi_text;
Content-type: text/html

<html><HEAD><META http-equiv="Content-Type" content="text/html; charset=euc-jp">
    <TITLE>BBS output</TITLE>
    </HEAD>
    <BODY bgcolor="#101040" text="#ffffff" link="#ff7f00" vlink="#ff0000" alink="#ff0000">
    <HR WIDTH="80%" SIZE=4>
    <H2 ALIGN="center">Test bbs (1行タイプ)</H2>
    <HR WIDTH="80%" SIZE=4>
    <H5 ALIGN="center">注1)ブラウザー設定で JavaScript が有効となっていない場合、誤動作の可能性があります。</H5>
    <H5 ALIGN="center">注2)漢字は EUC コード使用なので環境によっては文字化けするかもしれません。</H5>
    <BASEFONT SIZE="3">

Multi_text
}

sub pr_footer {
    print <<Multi_text;
    </BODY>
</HTML>

Multi_text
}


########## 入力用 form 出力 ##########
sub pr_form {
    print <<Multi_text;

<SCRIPT LANGUAGE="JavaScript">
<!--
function formcheck()
{
    len = document.form1.name.value.length;
    if ( len < 1 ) {
        alert("名前が入力されていません");
	return false;
    }
    len = document.form1.text.value.length;
    if ( len < 1 ) {
        alert("メッセージが入力されていません");
	return false;
    }
    return true;
}

function reload()
{
    document.formdmy.name.value = document.form1.name.value ;
    document.formdmy.utl.value  = document.form1.url.value ;
    document.formdmy.text.value = document.form1.text.value ;
    return true;
}

// -->
</SCRIPT>

<HR>
<TABLE BORDER="0">
<FORM NAME="form1" onSubmit="return formcheck()" onReset="return reset_reload()" ACTION="$cgi_file" METHOD="POST">
<TR><TD WIDTH=64>名前</TD><TD><INPUT TYPE="text" NAME="name" VALUE="$FORM{'name'}" SIZE=$max_name MAXLENGTH=$max_name></TD></TR>
<TR><TD WIDTH=64>URL</TD><TD><INPUT TYPE="text" NAME="url"  VALUE="$FORM{'url'}" SIZE=$max_url MAXLENGTH=$max_url>(省略可)</TD></TR>
<TR><TD WIDTH=64>本文</TD><TD><INPUT TYPE="text" NAME="text" SIZE=$ftext_size  MAXLENGTH=$max_text></TD></TR>
</TABLE>
<P>
<TABLE BORDER="0">
<TR><TD><INPUT TYPE="submit" VALUE="書き込み"></TD>
</FORM>

<FORM NAME="formdmy" onSubmit="return reload()" ACTION="$cgi_file" METHOD="POST">
<INPUT TYPE="hidden" NAME="name" VALUE="$FORM{'name'}" >
<INPUT TYPE="hidden" NAME="url"  VALUE="$FORM{'url'}" >
<INPUT TYPE="hidden" NAME="text" VALUE="" >
<TD><INPUT TYPE="submit"  VALUE="再表示"></TD>
</FORM>
</TABLE>

<HR>
あなたのブラウザー情報<BR>
REMOTE_HOST=$ENV{'REMOTE_HOST'}<BR>
REMOTE_ADDR=$ENV{'REMOTE_ADDR'}<BR>
HTTP_USER_AGENT=$ENV{'HTTP_USER_AGENT'}<BR>
<HR>

Multi_text
}


########## トップレコード変更 ##########
sub set_dataptr {
    $top_rec = sprintf("%07d:%07d:", $data_ptr, $data_num) . (" " x $record_size);
    seek(DATAFILE, 0, 0);
    print DATAFILE substr($top_rec, 0, $record_size);
}

########## メッセージ投稿 ##########
sub post_msg {
    my($name) = $FORM{'name'};
    my($text) = $FORM{'text'};
    my($url) = $FORM{'url'};
    my($l_name) = length($name);
    my($l_text) = length($text);
    my($l_url)  = length($url);
    if ( $l_name < 1 || $l_name > $max_name ) {
	print "名前が正しく入力されていません。";
	return;
    }
    if ( $l_text < 1 || $l_text > $max_text ) {
	print "本文が正しく入力されていません。";
	return;
    }
    if ( $l_url  > $max_url ) {
	print "urlが長過ぎます。";
	return;
    }
    
    if ( $l_url > 0 ) {
        if ( $url =~ /@/ && !($url =~ m#/#) ) {
	    $tmprecord = sprintf(' <A href="mailto:%s" >%s</A> : %s', $url, $name, $text);
        }  else {
	    if ( $url =~ /^http:/ ) {
		$tmprecord = sprintf(' <A href="%s" >%s</A> : %s', $url, $name, $text);
	    } else {
		$tmprecord = sprintf(' <A href="http://%s" >%s</A> : %s', $url, $name, $text);
	    }
	}
    } else {
	$tmprecord = sprintf(" %s : %s", $name, $text);
    }
# post
    my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time());
    $tmprecord = sprintf("%02d/%02d/%02d %02d:%02d ", $year %= 100, $mon+1, $mday, $hour, $min)
	. $tmprecord . "\n" . (" " x $record_size);
    seek(DATAFILE, $record_size * $data_ptr, 0);
    print DATAFILE substr($tmprecord, 0, $record_size);

# Pointer update
    $data_ptr++;
    if ($data_ptr > $record_max) {
	$data_ptr = $record_top;
    }
    $data_num++;
    if ($data_num > $record_max) {
	$data_num = $record_max;
    }
    &set_dataptr;

    &disp_msg;
}

########## メッセージ表示 ##########
sub disp_msg {
    my($name) = $FORM{'name'};
    my($text) = $FORM{'text'};
    my($mail) = $FORM{'mail'};

    my($tmp) = "";
    my($trash) = "";
    my($i) = 0;
    if ($i < $data_num) {
	my($ptr) = $data_ptr - 1;
	if ($ptr < $record_top) {
	    $ptr = $record_max;
	}
	for (my($i) = 0 ; $i < $data_num ; $i++) {
	    seek(DATAFILE, $record_size * $ptr, 0);
	    if (read(DATAFILE, $tmp, $record_size) > 1) {
		my(@data) = split(/\n/, $tmp, 2);
		print $data[0], "<BR>\n";
		$ptr--;
		if ($ptr < $record_top) {
		    $ptr = $record_max;
		}
	    } else {
		print "ファイル読み込み中に異常が発生しました。<BR>\n";
		last;
	    }
	}
    } else {
	print "書き込みはありません。<BR>\n";
    }

    print '<PRE>';
    print `ls -l ../bin`;
    print `echo "-----------------"`;
    print `ls -x`;
    print `/bin/df`;
    print '</PRE><HR>';
}

########## CGI FORM decode ##########
sub form_decode {
    my (%thash);
    my (@pairs) = split(/&/, $_[0]);
#print '@pairs =', @pairs , '<BR>';
    foreach (@pairs) {
	tr/+/ /;
   	s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	my ($key, $val) = split(/=/, $_, 2);
#print $key, ' ', $val , '<BR>';
	chomp( $val );
	$thash {$key} = htmltag_disable($val);
    }

    return (%thash);
}

########## HTML tag / \n を無効化(SJISではいまいち) ##########
sub htmltag_disable {
    $_ = $_[0];

    s/&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    s/"/&quot;/g;
    s/\n//g;

    return ($_);
}
総合ホームページ Perl納戸部屋