\n/\n/gi;
$s =~ s/&/&/g;
$s =~ s//>/g;
$s =~ s/"/"/g;
$s =~ s/'/'/g;
$s =~ s/\n/
\n/g;
$s =~ s/ / /g;
return $s;
}
sub GetHTMLParagraph
{
my ($str) = (@_);
$str =~ /^([\w\W\n]*?)()([\w\W]*)$/mi;
my $line = $1;
my $paragraph = $2;
my $len = length($line) + length($paragraph);
my $content = substr($str, $len);
return ($line, $paragraph, $content);
}
sub DequoteXML
{
my ($str,$DoDecode) = (@_);
$str =~ s/<[\w\W]*?>//gmi;
$str =~ s/\n//gm;
if($DoDecode) {
$str =~ s/"/\"/gmi;
$str =~ s/&nbps;/ /gmi;
}
return $_[0] = $str;
}
#===============================================
# HTML / Cookie関係
#===============================================
my %COOKIE;
my $CGIFiles = "(\.cgi|\.pl|\.php)[^/]*\$";
my @IndexFiles = ("index.html", "index.htm", "Index.html", "Index.htm",
"Default.htm", "Default.html", "default.htm", "default.html");
#
# Cookieの値を読み出す
#
sub getCookie {
my($xx, $name, $value);
foreach my $xx (split(/; */, $ENV{'HTTP_COOKIE'})) {
($name, $value) = split(/=/, $xx);
$value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/eg;
$COOKIE{$name} = $value;
}
}
#
# Cookieに値を書き込むためのSet-Cookie:ヘッダを生成する
#
sub setCookie {
my($tmp, $val);
$val = $_[1];
$val =~ s/(\W)/sprintf("%%%02X", unpack("C", $1))/eg;
$tmp = "Set-Cookie: ";
$tmp .= "$_[0]=$val; ";
$tmp .= "expires=Tue, 1-Jan-2030 00:00:00 GMT;";
return($tmp);
}
#
# Cookieを削除するためのSet-Cookie:ヘッダを生成する
#
sub clearCookie {
my $tmp = "Set-Cookie: ";
$tmp .= "$_[0]=xx; ";
$tmp .= " expires=Tue, 1-Jan-1980 00:00:00 GMT;";
return($tmp);
}
# Cookieの値を読み出す
#
sub MyGetCookie {
#print "Env: ", $ENV{'HTTP_COOKIE'}, "
\n";
foreach my $xx (split(/; */, $ENV{'HTTP_COOKIE'})) {
#print "xx: $xx
\n";
my ($name, $value) = split(/=/, $xx);
$value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/eg;
$COOKIE{$name} = $value if $COOKIE{$name} eq '';
#print "Name: $name, ", $COOKIE{$name}, "
\n";
}
}
sub ConvertHTMLToFullURL
{
my ($Content, $SourceURL, $Debug) = (@_);
my $res;
my $ConvContent;
$res = $Content;
$ConvContent = "";
while(1) {
my $count =
($res =~ /^(.*?)(\)(.*?)(\<\/a.*?\>)(.*)$/si);
if($count == 0) {
$ConvContent .= $res;
last;
}
my $header = $1;
my $tag1 = $2;
my $linkurl = $3;
my $tag2 = $4;
my $linkstr = $5;
my $tag3 = $6;
$res = $7;
if($Debug) {
print " URL: $linkurl\n";
}
my $convurl = &ConvertURLtoFullURL($linkurl, $SourceURL);
if($Debug) {
print "ConvURL: $convurl\n";
}
$ConvContent .= "$1$2$convurl$4$5$6";
}
$res = $ConvContent;
$ConvContent = "";
while(1) {
my $count =
($res =~ /^(.*?(background|image|src)\s*=\s*\")(.*?)(\".*)$/si);
if($count == 0) {
$ConvContent .= $res;
last;
}
my $header = $1;
my $linkurl = $3;
$res = $4;
if($Debug) {
print " URL: $linkurl\n";
}
my $convurl = &ConvertURLtoFullURL($linkurl, $SourceURL);
if($Debug) {
print "ConvURL: $convurl\n";
}
$ConvContent .= "$1$convurl";
}
return $_[0] = $ConvContent;;
}
sub ConvertURLtoFullURL
{
my ($linkurl, $url) = (@_);
my $convurl;
return $linkurl if($linkurl =~ /:\/\//i);
my $protocol;
my $server;
my $directory;
my $filename;
# $url =~ /^(.*?:\/\/)([^\/]+?)([^\?\&]*?)([^\/]*?)$/i;
$url =~ /^(.*?:\/\/)([^\/]+?)(\/|$)(.*?)([^\/]*?)$/i;
$protocol = $1;
$server = $2;
$directory = "/$4";
$filename = $5;
if($directory =~ /[\?\&]/) {
$directory =~ /^(.*?)([\?\&].*$)/;
$directory = $1;
my $res1 = $2;
$directory =~ /^(.*)\/([^\/]*?)$/;
$directory = $1;
my $res2 = $2;
$filename = "$res2$res1$filename";
}
#print "URL : $url\n";
#print "pro : $protocol\n";
#print "server: $server\n";
#print "dir : $directory\n";
#print "file : $filename\n";
my $path;
if($linkurl =~ /^\//) {
$path = &MakePath($server, $linkurl, "/", 0);
}
else {
$path = &MakePath($server, $directory, "/", 0);
$path = &MakePath($path, $linkurl, "/", 0);
&ReduceDirectory($path);
}
#print "path: $path\n";
$convurl = "$protocol$path";
return $convurl;
}
sub GetURLwithoutFilePath {
my ($url) = @_;
my $ret;
#CGIの場合はそのままreturn
return 1 if($url =~ /$CGIFiles/i or $url =~ /[\?\&]/);
for(my $i = 0 ; $i < @IndexFiles ; $i++) {
my $s = &MakePath($url, $IndexFiles[$i], "/", 0);
#print "url: $s\n";
$ret = head($s);
# $ret = get($s);
if($ret) {
$_[0] = $s;
return $ret;
}
}
return $ret;
}
sub DownloadFromURL
{
my ($url) = @_;
my $Content;
my $agent = LWP::UserAgent->new;
my $newagent = 'Mozilla/4.7 [en] (PalmOS)';
$agent->agent($newagent);
my $jar = $agent->cookie_jar(new HTTP::Cookies);
my $request = HTTP::Request->new(GET => $url);
my $response = $agent->request($request);
unless($response->is_success) {
my $s = $response->message;
print "Error: $s!
\n";
return -1;
}
$Content = $response->content;
&ConvertHTMLToFullURL($Content, $url, 0);
return $Content;
}
sub ExtractHTMLBody
{
my ($Content) = @_;
$Content =~ /\(.*)\<\/body\>/si;
return $1;
}
#タグの外側だけを置換
sub ReplaceHTMLBodyOnly
{
my ($str, $source, $target) = @_;
$str =~ s/((?:\G|>)[^<]*?)$source/$1$target/g;
return $str;
}
#データ中のHTMLタグを無力化
sub InvalidateHTMLTags
{
my ($input, $DoUpdate) = @_;
$DoUpdate = 1 if(!defined $DoUpdate);
$input =~ s/&/&/g;
$input =~ s//>/g;
$input =~ s/"/"/g;
$input =~ s/'/'/g;
$_[0] = $input if($DoUpdate);
return $input;
}
#URLから危険な要素を排除
sub GetSafeURL
{
my $url = @_;
return '' if($url =~ m|[^;/?:@&=+\$,A-Za-z0-9\-_.!~*'()%]|);
if($url =~ /^([A-Za-z][A-Za-z0-9+\-.]*):/) {
my $scheme = lc($1);
my $allowed = 0;
$allowed = 1 if($scheme eq 'http');
$allowed = 1 if($scheme eq 'https');
$allowed = 1 if($scheme eq 'mailto');
return '' if(not $allowed);
}
$url =~ s/&/&/g;
$url =~ s/'/'/g;
return $url;
}
#ファイル名のチェック（ヌル文字がある場合、ディレクトリィトラバーサルがある場合は０
sub CheckSecureFileName
{
my $fname = @_;
return 0 if($fname =~ <\.\./>);
return 0 if($fname =~ /\0/);
return 1;
}
1;