2ch.cgi (4694B)
1 #!/usr/bin/perl 2 3 $WGET = "wget"; 4 $SCRIPT_NAME = $ENV{'SCRIPT_NAME'} || $0; 5 $CGI = "file://$SCRIPT_NAME"; 6 $_ = $QUERY_STRING = $ENV{"QUERY_STRING"}; 7 $UserAgent = "Monazilla/1.00 (w3m/2ch.cgi)"; 8 9 if (/subback.html$/) { 10 &subback(); 11 exit; 12 } 13 14 s@/(\d+)(/([^/]*))?$@/$1@ || exit; 15 my $datnum = $1; 16 $label = $3; 17 $cgi = "$CGI?$_"; 18 19 s@^http://([^/]+)/test/read.cgi/([^/]+)/@$1/$2/dat/@ || exit; 20 $subback = "$CGI?http://$1/$2/subback.html"; 21 $bbs = $2; 22 if ($ENV{REQUEST_METHOD} eq "POST") { 23 &post(); 24 exit; 25 } 26 27 $_ .= ".dat"; 28 $dat = "http://$_"; 29 $tmp = $ENV{"HOME"} . "/.w3m2ch/$_"; 30 $dat =~ s/([^\w\/.\:\-])/\\$1/g; 31 $tmp =~ s/([^\w\/.\:\-])/\\$1/g; 32 ($dir = $tmp) =~ s@/[^/]+$@@; 33 $cmd = "mkdir -p $dir; $WGET -c -U \"$UserAgent\" -O $tmp $dat >/dev/null 2>&1"; 34 system $cmd; 35 $lines = (split(" ", `wc $tmp`))[0]; 36 $lines || exit; 37 38 @ARGV = ($tmp); 39 if ($label =~ /^l(\d+)/) { 40 $start = $lines - $1 + 1; 41 if ($start < 1) { 42 $start = 1; 43 } 44 $end = $lines; 45 } elsif ($label =~ /^(\d+)-(\d+)/) { 46 $start = $1; 47 $end = $2; 48 } elsif ($label =~ /^(\d+)-/) { 49 $start = $1; 50 $end = $start + 100 - 1; 51 } elsif ($label =~ /^(\d+)/) { 52 $start = $1; 53 $end = $1; 54 } else { 55 $start = 1; 56 $end = $lines; 57 } 58 $head = "<a href=\"$subback\">■掲示板に戻る■</a>\n"; 59 $head .= "<a href=\"$cgi/\">全部</a>\n"; 60 for (0 .. ($lines - 1) / 100) { 61 $n = $_ * 100 + 1; 62 $head .= "<a href=\"$cgi/$n-\">$n-</a>\n"; 63 } 64 $head .= "<a href=\"$cgi/l50\">最新50</a>\n"; 65 print <<EOF; 66 Content-Type: text/html 67 68 EOF 69 $i = 1; 70 while (<>) { 71 s/\r?\n$//; 72 ($name, $mail, $date, $_, $title) = split(/\<\>/); 73 if ($i == 1) { 74 if (!$title) { 75 print <<EOF; 76 このスレッドは過去ログ倉庫に格納されています。 77 <p> 78 <a href="$QUERY_STRING">$QUERY_STRING</a> 79 EOF 80 unlink($tmp); 81 exit 82 } 83 print <<EOF; 84 <title>$title</title> 85 $head 86 <p>$title</p> 87 <dl> 88 EOF 89 } 90 if ($mail) { 91 $name = "<a href=\"mailto:$mail\">$name</a>"; 92 } 93 s@http://ime.nu/@http://@g; 94 s@(h?ttp:)([#-~]+)@"<a href=\"" . &link("http:$2") . "\">$1$2</a>"@ge; 95 s@(ftp:[#-~]+)@<a href="$1">$1</a>@g; 96 s@<a href="../test/read.cgi/\w+/\d+/@<a href="$cgi/@g; 97 if ($i == 1 || ($i >= $start && $i <= $end)) { 98 print <<EOF; 99 <dt><a name="$i">$i</a> ：$name：$date 100 <dd> 101 $_ 102 <p> 103 EOF 104 } 105 $i++; 106 } 107 print <<EOF; 108 </dl> 109 <hr> 110 <form method=POST action="$cgi"><input type=submit value="書き込む" name=submit> 名前： <input name=FROM size=19> E-mail<font size=1> (省略可) </font>: <input name=mail size=19><br><textarea rows=5 cols=70 wrap=off name=MESSAGE></textarea><input type=hidden name=bbs value=$bbs><input type=hidden name=key value=$datnum><input type=hidden name=time value=@{[time]}></form></body></html> 111 EOF 112 113 sub link { 114 local($_) = @_; 115 if (m@/test/read.cgi/@) { 116 return "$CGI?$_"; 117 } 118 return $_; 119 } 120 121 sub subback { 122 $dat = $_; 123 s@http://@@ || exit; 124 $tmp = $ENV{"HOME"} . "/.w3m2ch/$_"; 125 $dat =~ s/([^\w\/.\:\-])/\\$1/g; 126 $tmp =~ s/([^\w\/.\:\-])/\\$1/g; 127 ($dir = $tmp) =~ s@/[^/]+$@@; 128 $cmd = "mkdir -p $dir; $WGET -O $tmp $dat >/dev/null 2>&1"; 129 system $cmd; 130 print <<EOF; 131 Content-Type: text/html 132 133 EOF 134 @ARGV = ($tmp); 135 while (<>) { 136 if (/<base href="([^"]+)"/) { 137 $base = $1; 138 } elsif ($base) { 139 s@^<a href="@<a href="$CGI?$base@; 140 } 141 print; 142 } 143 unlink($tmp); 144 } 145 146 sub post { 147 my $debug = 0; 148 149 $| = 1; 150 use IO::Socket; 151 my @POST = <>; 152 $QUERY_STRING =~ m@^http://([^/]+)@; 153 my $host = $1; 154 my $sock = IO::Socket::INET->new("$host:80") or die; 155 # retrieve posting cookie; this may not work 156 print "Content-Type: text/html\n\n"; 157 print $sock 158 "HEAD /test/bbs.cgi HTTP/1.1\n", 159 "Host: $host\n", 160 "Connection: keep-alive\n", 161 "\n"; 162 my $posting_cookie = undef; 163 while (<$sock>) { 164 print if ($debug); 165 s/[\n\r]+$//; 166 last if (/^$/); 167 if (/^set-cookie:.*(PON=[^;]+)/i) { 168 $posting_cookie = $1; 169 } 170 } 171 #$sock = IO::Socket::INET->new("$host:80") or die; 172 my $submit = 173 "POST /test/bbs.cgi HTTP/1.1\n" . 174 "Host: $host\n" . 175 "Accept-Language: ja\n" . 176 "User-Agent: $UserAgent\n" . 177 "Referer: $QUERY_STRING\n" . 178 "Cookie: $posting_cookie; NAME=nobody; MAIL=sage\n" . 179 "Content-Length: " . length(join("", @POST)) . "\n" . 180 "\n@POST"; 181 print $sock $submit or die; 182 print "\n-- POSTed contents --\n${submit}\n-- POSTed contents --\n" 183 if ($debug); 184 my $chunked = 0; 185 while (<$sock>) { 186 s/[\n\r]*$//; 187 last if (/^$/); 188 $chunked = 1 if (/^transfer-encoding:\s*chunked/i); 189 } 190 my $post_response = ""; 191 while (<$sock>) { 192 if ($chunked) { 193 s/[ \r\n]*$//; 194 my $len = hex($_); 195 $len > 0 or last; 196 read($sock, $_, $len); 197 <$sock>; #skip empty line at the end of chunk. 198 } 199 $post_response .= $_; 200 } 201 $post_response =~ s/<META content=(\d+);URL=(\S+) http-equiv=refresh>/<META content=$1;URL=$cgi http-equiv=refresh>/im; 202 print $post_response; 203 exit; 204 }