1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
|
#!/usr/bin/perl
# ↑は「#!/usr/local/bin/perl」が一般的みたいなの。
# 動かないときはプロバイダに訊くの。
#BEGIN{
# print "Content-type: text/plain\n\n";
# open(STDERR, ">&STDOUT");
# $|=1;
#}
# ↑はエラーが出て困った時にコメントを外すの。
require 5.005;
use strict;
# ↑はさわったらだめなの。
# いくつか設定することがあるの。
my @max_list = qw(10 20 30 40 50);
# 入口では表示する件数を選べるの。
# ここに書いたのがドロップダウンに表示されるの。
# でも、あんまり大きい数はいやなの。
# 数字以外も書けるけど、書いたらいやなの。
my $return_uri = '../nanochat.htm';
# 「戻るの。」でリンクする場所を決める事ができるの。
my $ss_uri = './nanochat.css';
# スタイルシートの場所なの。
# このファイルはスクリプトと同じ場所だと効かない事があるらしいの。
# そういう人はスタイルシートを他の場所において、ここを変えるの。
# その時は「http://」から書いたほうが確実なの。
my $timeout = 1800;
# 書込みしてない人はクッキーの期限が切れるの。
# その時間を決める事ができるの。単位は秒なの。
my $main_log = './main.log';
# 会話の中身を記録するファイルの名前なの。
# 最初はこの名前だから、そのまま使うときは変えなくてもいいの。
my $member_log = './member.log';
# 誰が居るかを記録するファイルの名前なの。
# 最初はこの名前だから、そのまま使うときは変えなくてもいいの。
my $nano = 'なの';
# これを変えたらなのじゃなくなるの。でもべつにいいの。
my $script_uri = $ENV{SCRIPT_NAME} || './nanochat.cgi';
# このファイルの名前を変えたら、右側の方にその名前を書くの。
# ここから・・・
my $msg_max = ( sort { $b <=> $a } @max_list )[0];
my $msg_min = ( sort { $a <=> $b } @max_list )[0];
my $script_name = 'NANOChat';
my $print_str = '';
my $print_header = '';
my %members = ();
my %ip = ();
my @logs = ();
my @logs_now = ();
# ここまでは変えたらいやなの。
# お仕事できなくなるの。
check_env();
# ↑はうまく動くか試してるの。ちゃんと動いたら消してもいいの。
# 心配な人は消さなくてもいいの。
# ここから最後までは細かい事をやってるの。
# わからない人はさわったらダメなの。
main();
print_exit();
sub main {
my $cookie = get_cookie();
# HTMLのチェック用なの。
# $cookie = ',10';
# $cookie = '61,10';
# $ENV{QUERY_STRING} = 'logout=1';
# ここまでなの。でも、下のほうにもう少しあるの。
if ( defined $cookie ) {
my ( $name, $tmp ) = split /,/, $cookie, 3;
if ($name) {
$name = pack( "H*", $name );
check_max($tmp);
}
my %form = (); # (ua => $ENV{HTTP_USER_AGENT});
foreach ( split /[&;]/, $ENV{QUERY_STRING} ) {
my ( $key, $value ) = split /=/, $_, 2;
if ( $value =~ /[%\+]/ ) {
my $space = "(?:\xA1\xA1)";
$value =~ tr/+/ /;
$value =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("H2", $1)/eg;
$value =~ s/&/&/g;
$value =~ s/</</g;
$value =~ s/>/>/g;
$value =~ s/\t/ /g;
$value =~ s/^(\s|$space)+//o;
$value =~ s/(\s|$space)+$//o;
$value =~ s/ / /g;
$value =~ tr/\x0D\x0A//d;
}
$form{$key} = $value;
}
member_read();
# HTMLチェック用なの。
# $members{'a'} = time; $ip{'a'} = '127.0.0.1';
# これだけなの。
if ( exists $form{logout} ) {
ref_logout( \%form, $name );
print_exit();
}
elsif ( exists $form{login} and $name eq '' ) {
ref_login( \%form );
$name = $form{n};
check_max( $form{max} );
}
log_read();
if ($name) {
$form{msg} ne '' and ref_make_log( \%form, $name );
my $cname = unpack( "H*", $name );
$print_header = "Set-Cookie: $script_name=$cname,$msg_max; expires="
. gmtime( time + $timeout ) . "\n";
reload($name);
}
else {
stock_header('名前を教えてほしいの。');
stock_member();
my $sel = qq(<select name="max">);
my $sd = qq( selected);
foreach (@max_list) {
$sel .= qq(<option value="$_"$sd>$_ 件</option>);
$sd = '';
}
$sel .= '</select>';
$print_str .= <<EOM;
<div class="nano">
<form method="get" action="$script_uri">
<p><input type="text" name="n" size="20" maxlength="20" tabindex="1"> ←ここに名前を書いてほしいの。</p>
<p>書いたら、表示するメッセージ数を $sel にして <input type="submit" value="部屋に入るの。" tabindex="2"><input type="hidden" name="login" value="1"></p>
<p><input type="submit" name="logout" value="やっぱり帰るの。" tabindex="3"></p>
</form></div><hr>
EOM
stock_log($msg_min);
stock_footer();
}
}
else {
$print_header = "Set-Cookie: $script_name=,10; expires="
. gmtime( time + $timeout ) . "\n";
stock_header('いらっしゃいなの。');
my $limit = int( $timeout / 60 );
$print_str .= <<EOM;
<div class="nano">
<p>ここの入退室管理を任されてる <strong class="name">$nano</strong> なの。よろしくなの。</p>
<p>この部屋へ入るにはクッキーが必要なの。退室するときにちゃんと消してあげるから、名札だと思ってつけてほしいの。今つけた人は、ついてるかどうかわからないから１回読みなおしてほしいの。</p>
<p>JavaScriptが使えると、マウスを使わなくてもチャットできるの。とってもおすすめなの。</p>
<p>あと、$limit分くらい何も発言しないと部屋から追い出されちゃうの。気をつけてほしいの。</p>
<p>あ、ホームページ（http://から書くの）とかメールアドレス（mailto:から書くの）とかを書くと、リンクしてあげるの。よくわからないから発言を全部リンクしちゃうけど、そのくらいは許してほしいの。</p>
<p>準備ができたら<a href="$script_uri">入口</a>で名前を教えてほしいの。</p>
</div>
EOM
stock_footer();
}
}
sub member_read {
open IN, $member_log or die;
my $member = <IN>;
my $ip = <IN>;
close IN;
chomp $member;
chomp $ip;
%members = split /\t/, $member;
%ip = split /\t/, $ip;
foreach ( keys %members ) {
if ( $timeout < time - $members{$_} ) {
delete $members{$_};
delete $ip{$_};
}
}
}
sub member_write {
my $member = join( "\t", %members );
my $ip = join( "\t", %ip );
open OUT, "> $member_log" or die;
print OUT $member . "\n";
print OUT $ip . "\n";
close OUT;
}
# ファイルを最後の方から読むの。
# Perlメモ（http://www.din.or.jp/~ohzaki/perl.htm）を参考にしたの。
# でも、ほとんどそのままなの。
sub log_read {
my $bufsize = 1024;
my $pos = 0;
open IN, $main_log or die;
binmode(IN);
my $size = ( -s IN ) / $bufsize;
$pos += $size <=> ( $pos = int($size) );
my $buf_tmp = '';
while ( $pos-- ) {
my $buf = '';
my @lines = ();
seek( IN, $bufsize * $pos, 0 );
read( IN, $buf, $bufsize );
$buf .= $buf_tmp;
( $buf_tmp, @lines ) = $buf =~ /[^\x0D\x0A]*\x0D?\x0A?/g;
pop(@lines);
unshift( @logs, @lines );
next if @logs < $msg_max;
last;
}
close IN;
unshift( @logs, $buf_tmp ) if $buf_tmp;
# 最後まで読んでる事も多いから必要なの。
# @logs = @logs[-$msg_max .. -1] if @logs > $msg_max;
# 本当は余ったら切らないといけないの。
# でも、表示する時に切るから放っておくの。
}
sub log_write {
open OUT, ">> $main_log" or die;
seek OUT, 0, 2;
print OUT "$_\n" foreach reverse @logs_now;
close OUT;
return if %members;
$msg_max = ( sort { $b <=> $a } @max_list )[0];
@logs = ();
log_read();
open OUT, "> $main_log" or die;
foreach (@logs) {
tr/\x0D\x0A//d;
$_ or next;
print OUT "$_\n";
}
close OUT;
}
sub ref_login {
my ($f) = @_;
$f->{n}
or error_exit("名前を教えてほしいって言ってるの。名無しさんはいやなの。");
$f->{n} eq $nano
and error_exit(
qq(<strong class="name">$f->{n}</strong> はわたしなの。同じ名前はいやなの。)
);
exists $members{ $f->{n} }
and $ip{ $f->{n} } ne $ENV{REMOTE_ADDR}
and error_exit(
qq(<strong class="name">$f->{n}</strong> さんはもういるの。名前を変えてほしいの。)
);
$members{ $f->{n} } = time;
exists $ip{ $f->{n} } and return;
$ip{ $f->{n} } = $ENV{REMOTE_ADDR};
ref_make_log(
{
msg =>
qq(<strong class="name">$f->{n}</strong> さんが入室したの。仲良くしてなの。),
},
$nano
);
}
sub ref_logout {
my ( $f, $name ) = @_;
$print_header =
"Set-Cookie: $script_name=,0; expires=Sat Jan 1 00:00:00 2000\n";
if ( delete $members{$name} and delete $ip{$name} ) {
ref_make_log(
{
msg =>
qq(<strong class="name">$name</strong> さんが退室したの。ちょっと淋しいの。),
},
$nano
);
%members
or
ref_make_log( { msg => '誰もいなくなったの。淋しいの。', }, $nano );
stock_header('ばいばいなの。');
$print_str .= <<EOM;
<div class="nano">
<p><strong class="name">$name</strong> さん、ありがとうなの。また来てほしいの。</p>
<p>そういえば、ブラウザに履歴がいっぱいあると思うの。ごめんねなの。</p>
<p><a href="$return_uri">戻るの。</a></p>
</div>
EOM
log_write();
member_write();
stock_footer();
}
else {
stock_header('残念なの。');
$print_str .= <<EOM;
<div class="nano">
<p>今度はちゃんと入ってほしいの。また来てなの。</p>
<p><a href="$return_uri">戻るの。</a></p>
</div>
EOM
stock_footer();
}
}
sub get_cookie {
return undef unless my $http_cookie = $ENV{HTTP_COOKIE};
$http_cookie =~ tr/ //d;
foreach ( split( /;/, $http_cookie ) ) {
my ( $key, $value ) = split( /=/, $_, 2 );
next if $key ne $script_name;
return $value;
}
return undef;
}
sub ref_make_log {
my ( $f, $name ) = @_;
my $str = '';
my @date = localtime;
if ( index( $f->{msg}, "http://" ) == 0
or index( $f->{msg}, "mailto:" ) == 0 )
{
$f->{msg} = qq(<a href="$f->{msg}">$f->{msg}</a>);
}
$f->{msg} .= sprintf " <small>(%ld/%02d/%02d %02d:%02d:%02d)</small>",
$date[5] + 1900, $date[4] + 1, @date[ 3, 2, 1, 0 ];
if ( $name eq $nano ) {
$str = qq(<p class="nano">);
}
else {
$str = "<p>";
$members{$name} = time;
}
unshift @logs_now,
qq($str<strong class="name">$name</strong> ： $f->{msg}</p>);
}
sub reload {
stock_header( $nano . 'チャットなの。' );
stock_member();
$print_str .= <<EOM;
<div class="nano">
<form method="get" action="$script_uri">
<p>あなたは <strong class="name">$_[0]</strong> さんなの。改行するとたぶん送信するの。何も書いてない時は再読込になるの。</p>
<p><input type="text" name="msg" size="80" value="" tabindex="1"><br><input type="submit" value="送信するの。" tabindex="2"> <input type="submit" name="logout" value="退室するの。" tabindex="3"></p>
</form></div><hr>
EOM
stock_log($msg_max);
stock_footer();
if (@logs_now) {
log_write();
member_write();
}
}
sub stock_member {
my $cnt = 0;
$print_str .= qq(<p class="nano">今は、 );
foreach ( sort { $members{$b} <=> $members{$a} } keys %members ) {
$print_str .= qq(<strong class="name">$_</strong> さんと );
++$cnt;
}
my $only = $cnt ? " " : " だけ";
$print_str .= qq(<strong class="name">$nano</strong>$onlyがいるの。</p>\n);
}
sub stock_log {
my $cnt = 0;
@logs_now or @logs or return;
$print_str .= qq(<div class="logs">);
foreach ( @logs_now, reverse @logs ) {
$_[0] < ++$cnt and last;
tr/\x0D\x0A//d;
$print_str .= $_;
}
$print_str .= '</div>';
}
sub stock_header {
$print_str .= <<EOM;
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"
"http://www.w3.org/TR/html4/strict.dtd">
<html lang="ja">
<head>
<link rel="stylesheet" type="text/css" href="$ss_uri" title="Default" media="screen">
<meta name="ROBOTS" content="NOINDEX">
<title>$_[0]</title>
</head>
<body onload="obj = document.forms[0];if(obj)obj.elements[0].focus();">
<h2 class="nano">$_[0]</h2><hr>
EOM
}
sub stock_footer {
my $cost = sprintf "このお仕事に %.2f 秒くらいかかったの。", times;
my $copy =
qq(<a href="http://www.age.ne.jp/x/nobu3/perl/nanochat.htm" title="このスクリプトの最新版はこのリンク先にあるの。">$script_name Ver0.12</a>);
$print_str .= <<EOM;
<hr>
<p class="nano">$cost</p>
<address>$copy</address>
</body>
</html>
EOM
}
sub error_exit {
$print_str = '';
stock_header('そんな事したらダメなの。');
$print_str .= <<EOM;
<div class="nano">
<p>$_[0]</p>
<p>お仕事の邪魔しないでほしいの。<a href="$script_uri">入口まで戻るの。</a></p>
</div>
EOM
stock_footer();
print_exit();
}
sub print_exit {
$print_str =~ tr/\x0D\x0A//d;
print "Content-Type: text/html; charset=euc-jp\n";
print "Content-Language: ja\n";
print "Content-Script-Type: text/javascript\n";
print "Content-Style-Type: text/css\n";
print "Pragma: no-cache\n";
print "Cache-Control: no-cache\n";
$print_header and print $print_header;
printf "Content-Length: %ld\n", length $print_str;
print "\n";
print $print_str;
exit;
}
sub check_max {
my ($num) = @_;
$num = $msg_min if $num =~ /\D/;
$msg_max = $msg_max < $num ? $msg_max : $num < $msg_min ? $msg_min : $num;
}
sub check_env {
my $str = '';
-r $main_log or $str .= $main_log . 'が読めないの。<br>';
-w $main_log or $str .= $main_log . 'に書けないの。<br>';
-r $member_log or $str .= $member_log . 'が読めないの。<br>';
-w $member_log or $str .= $member_log . 'に書けないの。<br>';
ord('漢') == 0xb4
or $str .=
qq(<strong class="name">$nano</strong> は、eucが好きなの。変えてほしいの。<br>);
$str and error_exit($str);
}
__END__
Ver 0.10 (2000/12/27)
公開版。
Ver 0.11 (2001/04/19)
入室時の２重投稿チェックをして入室ミスをなるべく防ぐようにした。
ログの表示件数を正確にした。
URIとMailに自動リンク。ただしとっても手抜き。
出力するHTMLをHTML4.01Strict相当にした。
Ver 0.12 (2001/04/26)
名前の変更ができてしまうのを修正。
最大表示件数のチェックを強化。
ロボット対策をつけた。
スタイルシートを若干変更。
|