創業132年を誇る超老舗のPerl/CGIスクリプト卸問屋へようこそ。当店では最先端技術を駆使して作成したスクリプトを格安のパッケージにして販売するかもしれませんが現在は産地直送のため時価です。当社が持てる技術の粋を集めた7行シリーズをよろしく！(結構適当なのは内緒)
| DOCUMENT_ROOT | /home/tonya/public_html/ |
| GATEWAY_INTERFACE | CGI/1.1 |
| HTTP_ACCEPT | text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 |
| HTTP_ACCEPT_ENCODING | gzip |
| HTTP_HOST | tonya.usamimi.info |
| HTTP_USER_AGENT | CCBot/2.0 (http://commoncrawl.org/faq/) |
| HTTP_X_FORWARDED_FOR | 54.81.116.187, 10.0.0.4 |
| HTTP_X_VARNISH | 4010406 |
| PATH | /usr/local/bin:/usr/bin:/bin |
| QUERY_STRING | d=2415919104&source=project/mod_chat.cgi |
| REMOTE_ADDR | 54.81.116.187 |
| REMOTE_PORT | 40181 |
| REQUEST_METHOD | GET |
| REQUEST_URI | /cgi-bin/index.cgi?d=2415919104&source=project/mod_chat.cgi |
| SCRIPT_FILENAME | /home/tonya/public_html/cgi-bin/index.cgi |
| SCRIPT_NAME | /cgi-bin/index.cgi |
| SERVER_ADDR | 10.0.0.8 |
| SERVER_ADMIN | tonya@usamimi.info |
| SERVER_NAME | tonya.usamimi.info |
| SERVER_PORT | 80 |
| SERVER_PROTOCOL | HTTP/1.1 |
| SERVER_SIGNATURE | <address>Apache Server at tonya.usamimi.info Port 80</address> |
| SERVER_SOFTWARE | Apache |
| UNIQUE_ID | WtoQ0QoAAAgAAN3aVuQAAAAi |
#!/usr/local/bin/speedy -- -r0 -t3600
# データをメモリーに保持する記録ファイル不要の mod_perl 専用チャット
# speedy でも動くようですがすぐにリセットされるかも。
my $lines = 10;
my $time_limit = 10 * 60;
my $max_user = 100;
use CGI qw/:standard/;
our %user;
our @data;
my $id = crypt join(
'',
map sprintf("%02x", $_),
grep /^\d{1,3}$/ && $_ <= 255,
split /\./, substr $ENV{'REMOTE_ADDR'} || '127.0.0.1', 0, 32
), $ENV{'SERVER_ADDR'} || '00';
delete @user{grep $user{$_}{'utime'} + $time_limit < time, keys %user};
unless (exists $user{$id} && time < $user{$id}{'utime'} + $time_limit) {
if ($max_user > keys %user) {
$user{$id} = {
'utime' => time,
'status' => 'passive',
'id' => substr crypt(substr($id, 2), join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]), 2
};
}
} else {
$user{$id}{'utime'} = time;
}
print header(-type => 'text/html', -charset => 'Shift_JIS'),
start_html(-title => 'mod_chat', -declare_xml => 1, -encoding => 'Shift_JIS', -lang => 'ja'),
start_form,
do {
unless (exists $user{$id}) {
'大変混み合っているため新規参加はできません。'
} elsif (param('name')) {
my $name = substr param('name'), 0, 32;
if (param('msg')) {
@data = (
{
'utime' => time,,
'id' => $user{$id}{'id'},
'name' => $name,
'msg' => substr(param('msg'), 0, 256)
},
splice @data, 0, $lines - 1
);
$user{$id}{'status'} = 'active';
}
escapeHTML($name), ':', textfield(-name => 'msg', -size => 40),
hidden(-name => 'name', -value => escapeHTML($name))
} else {
'名前:', textfield(-name => 'name', -size => 20)
}
},
submit(-value => '送信'),
end_form,
ul(
li([
map {
join ' ',
font({-color => 'green'}, b(escapeHTML($_->{'name'} . ':'))),
escapeHTML($_->{'msg'}),
font(
{-color => 'green', -size => -1},
sub {
i(sprintf "%d/%02d/%02d %02d:%02d:%02d", 1900 + $_[5], 1 + $_[4], @_[3, 2, 1, 0])
}->(gmtime 9 * 60 * 60 + $_->{'utime'})
),
font(
{-color => 'gray', -size => -1},
qq{($_->{'id'})}
)
} grep ref eq 'HASH', @data
])
),
do {
my %num = (
'active' => 0,
'passive' => 0
);
foreach (keys %user) {
$num{$user{$_}{'status'}}++;
}
p(small('閲覧者(' . $num{'passive'} . ') 参加者(' . $num{'active'} . ')'))
},
comment(escapeHTML($ENV{'MOD_PERL'} || '')),
end_html;©2018 Perl/CGIスクリプト卸問屋