)([\w\W]*)$/mi;
my $line = $1;
my $paragraph = $2;
my $len = length($line) + length($paragraph);
my $content = substr($str, $len);
# print "strlen: " . length($str) . " " . $len . " " . length($content) . "\n";
# print "str1: ". substr($str, 0, 200) . "\n";
# print "line1: $line\n";
# print "para1: $paragraph\n";
# my $cont1 = substr($content, 0, 200);
# print "cont1: $cont1\n";
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/</\/gmi;
$str =~ s/&nbps;/ /gmi;
}
return $_[0] = $str;
}
sub GetIPAddress
{
my($ip) = (@_);
$ip = $ENV{'REMOTE_ADDR'};
return $ip;
}
sub IsJapanese
{
my($str) = (@_);
Jcode::convert(\$str, 'euc');
if($str =~ /[\x8E\xA1-\xFE]/) {
return 1;
}
return 0;
}
#==========================================
# Decode / Encode
#==========================================
sub MySQLQuote
{
my($str,$mysqlcharcode) = (@_);
#print "s: $str
\n";
Jcode::convert(\$str, $mysqlcharcode)
if($mysqlcharcode ne '');
$str =~ s/\\/\\\\/g; # \
## $str =~ s/\c[/\\\c[/g; # ESC
# $str =~ s/\//\\\//g; # \
$str =~ s/\"/\\\"/g;
# $str =~ s/\'/\\\'/g;
# $str =~ s/\:/\\\:/g;
# $str =~ s/\(/\\\(/g;
# $str =~ s/\)/\\\)/g;
## $str =~ s/\[([^\c[])/\\\[\1/g;
# $str =~ s/\[/\\\[/g;
## $str =~ s/\]/\\\]/g;
#print "s: $str
\n";
return $str;
}
sub RegExpQuote
{
my($str) = (@_);
$str =~ s/\\/\\\\/g;
$str =~ s/\//\\\//g;
$str =~ s/\(/\\\(/g;
$str =~ s/\)/\\\)/g;
$str =~ s/\[/\\\[/g;
$str =~ s/\]/\\\]/g;
$str =~ s/\^/\\\^/g;
$str =~ s/\$/\\\$/g;
$str =~ s/\*/\\\*/g;
$str =~ s/\?/\\\?/g;
$str =~ s/\+/\\\+/g;
$str =~ s/\./\\\./g;
return $str;
}
sub URLEncode
{
my ($s) = (@_);
$s =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$s =~ tr/ /+/;
return $s;
}
sub URLDecode
{
my ($s2) = (@_);
#print "s0: $s2
\n";
$s2 =~ tr/+/ /;
$s2 =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
#print "s1: $s2
\n";
return $s2;
}
#16進コード
sub StrToHex
{
my ($s) = @_;
$s =~ s/(.)/'\\x' . uc unpack('H2', $1)/eg;
return $s;
}
sub RecoverHTMLChar
{
my ($s, $charset) = @_;
$s =~ s/&#([0-9]+);/pack('I', $1)/eg;
Jcode::convert(\$s, $charset)
if($charset ne '');
return $s;
}
sub StringToHex
{
my ($s) = @_;
$s = '='.unpack("H2",$s);
tr/a-f/A-F/;
return $s;
}
sub QPEncode
{
my ($string) = (@_);
$string =~ s/=/=3D/g;
$string =~ s/\t$/=09/;
$string =~ s/ $/=20/;
$string =~ s/([^!-" \t])/&StringToHex($1)/eg;
return $string;
}
sub QPDecode
{
my ($string) = (@_);
$string =~ s/=\r\n//g;
$string =~ s/=\n//g;
$string =~ s/=\r//g;
$string =~ s/=([0-9a-z]{2})/pack("C",hex($1))/gei;
return $string;
}
my $Base64Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
'abcdefghijklmnopqrstuvwxyz'.
'0123456789+/'; # and '='
my $Base64Pad = '=';
# b64decodesub -- takes some characters in the base64 alphabet and
# returns the raw bytes that they represent.
sub Base64DecodeSub
{
local ($_) = @_[0];
# translate each char to a value in the range 0 to 63
eval qq{ tr!$Base64Alphabet!\0-\77!; };
# keep 6 bits out of every 8, and pack them together
$_ = unpack('B*', $_); # look at the bits
s/(..)(......)/$2/g; # keep 6 bits of every 8
s/((........)*)(.*)/$1/; # throw away spare bits (not multiple of 8)
$_ = pack('B*', $_); # turn the bits back into bytes
$_; # return
}
sub Base64Decode2
{
my ($str) = (@_);
my $leftover = '';
# ignore illegal characters
$str =~ s/[^$Base64Alphabet]//go;
# insert the leftover stuff from last time
$str = $leftover . $str;
# if there are not a multiple of 4 bytes, keep the leftovers for later
$str =~ m/^((....)*)/;
$str = $&;
$leftover = $';
# turn each group of 4 values into 3 bytes
$str =~ s/(....)/&Base64DecodeSub($1)/eg;
# special processing at EOF for last few bytes
if (eof)
{
$str .= &Base64DecodeSub($leftover);
$leftover = '';
}
# output it
return $str;
}
sub Base64Decode
{
return decode_base64($_[0]);
}
sub Base64Encode
{
return encode_base64($_[0]);
}
#==========================================
# Directory
#==========================================
my $DirectorySeparator = "\\";
sub ConvertDirectorySeparator
{
my ($path, $src, $target, $DoTerminate) = (@_);
$src = &RegExpQuote($src);
# $target = &RegExpQuote($target);
$_[0] =~ s/^\s*//;
$_[0] =~ s/\s*$//;
if($_[0] eq '') {
return $_[0];
}
#print "str :" . $_[0] . "
\n";
#print "src :$src
\n";
#print "target:$target
\n";
$_[0] =~ s/$src/$target/g;
#print "str2 :" . $_[0] . "
\n";
my $RegTarget = &RegExpQuote($target);
if($DoTerminate) {
unless($_[0] =~ /$RegTarget$/) {
$_[0] .= $target;
}
}
else {
if($_[0] =~ /$RegTarget$/) {
$_[0] =~ s/$target$//;
}
}
#print "str3 :" . $_[0] . "
\n";
return $_[0];
}
sub MakePath
{
my ($dir, $fname, $separator, $DoTerminate) = (@_);
my $RegSep = &RegExpQuote($separator);
my $IsHeadSep = 0;
# $IsHeadSep = 1 if($dir =~ /^\//);
#print "MakePath:dir : $dir\n";
#print "MakePath:fname: $fname\n";
$fname =~ s/^\///;
if($dir =~ /$RegSep$/) {
$dir .= $fname;
}
else {
$dir .= $separator . $fname;
}
if($DoTerminate) {
unless($dir =~ /$RegSep$/) {
$dir .= $separator;
}
}
else {
if($dir ne '/' and $dir =~ /$RegSep$/) {
$dir =~ s/$RegSep$//;
}
}
# if($IsHeadSep) {
# $dir = "/$dir" unless($dir =~ /\//);
# }
#print "path: $dir\n";
return $dir;
}
sub ReduceDirectory {
my ($dir) = (@_);
my $IsHeadSep = 0;
my $IsLastSep = 0;
$IsHeadSep = 1 if($dir =~ /^\//);
$IsLastSep = 1 if($dir =~ /\/$/);
my @d = split(/\//, $dir);
my @d2;
for(my $i = 0 ; $i < @d ; $i++) {
next if($d[$i] eq '.');
if($d[$i] eq '..') {
pop(@d2);
next;
}
push(@d2, $d[$i]);
}
if($IsHeadSep) {
$dir = '/';
}
else {
$dir = '';
}
foreach my $dd (@d2) {
if($dir eq '') {
$dir = $dd;
next;
}
next if($dd eq '');
$dir = &MakePath($dir, $dd, "/", 0);
}
$dir = &MakePath($dir, "/", "/", 0) if($IsLastSep);
return $_[0] = $dir;
}
sub CreateDirecotry
{
my ($dir, $dirsep) = @_;
my $directorysep = $DirectorySeparator;
$directorysep = $dirsep;
$dir =~ s/\\/\//g;
if($Debug) {
print "CreateDirectory: $dir\n";
}
# my $IsHeadSep = 0;
# $IsHeadSep = 1 if($dir =~ /^\//);
my $IsRelative = 1;
$IsRelative = 0 if($dir =~ /^[A-Za-z]:\// or $dir =~ /^\//);
#print "IsRelative: $IsRelative\n";
my @eachpath = split(/\//, $dir);
my $i = 0;
my $path = "";
if($eachpath[$i] =~ /^[A-Za-z]:/) {
$path = $eachpath[$i];
$i++;
}
$path .= $directorysep unless($IsRelative);
for( ; $i < @eachpath ; $i++) {
$path .= $eachpath[$i] . $directorysep;
if($Debug) {
print "path: $path\n";
}
next if(-d $path);
if(-f $path) {
print "Can not create [$path]: $path is a file.\n";
return;
}
if($Debug) {
print " Create $path [$directorysep]\n";
}
mkdir($path);
}
}
sub MakeRelativePath
{
my ($SourceURL, $ParentURL, $Separator) = (@_);
$Separator = $DirectorySeparator if($Separator eq '');
my $HeadLevel = 2;
$HeadLevel = 3 if($SourceURL =~ m|://|);
if($Debug) {
print "*SourceURL: $SourceURL\n";
print "*ParentURL: $ParentURL\n";
print "*Separator: $Separator\n";
}
my $RegSeparator = &RegExpQuote($Separator);
my @EachSourceStr = split(/$RegSeparator/, $SourceURL);
my @EachParentStr = split(/$RegSeparator/, $ParentURL);
my $pt = 0;
for(my $i = 0 ; $i < @EachSourceStr ; $i++) {
if($Debug) {
print " es[$i]: ", lc $EachSourceStr[$i], "\n";
print " ep[$i]: ", lc $EachParentStr[$i], "\n";
}
if(lc $EachSourceStr[$i] ne lc $EachParentStr[$i]) {
$pt = $i;
last;
}
$pt = $i;
}
if($Debug) {
print "PT: $pt\n";
}
#絶対パスしかない場合
return "" if(($EachSourceStr[0] =~ /^\w:/ and $pt < $HeadLevel) or
($EachSourceStr[0] !~ /^\w:/ and $pt < $HeadLevel-1) );
my $TotalLevel = @EachParentStr - $pt - 1;
if($Debug) {
print "TotalLevel: $TotalLevel\n";
}
my $RelPath = '';
for(my $i = 0 ; $i < $TotalLevel ; $i++) {
$RelPath = &MakePath($RelPath, "..", $Separator, 0);
}
for(my $i = $pt ; $i < @EachSourceStr ; $i++) {
$RelPath = &MakePath($RelPath, $EachSourceStr[$i], $Separator, 0);
}
if($Debug) {
print "*RelPath: $RelPath\n";
}
return $RelPath;
}
sub CopyFile
{
my ($infile, $outfile) = (@_);
open(IN, "<$infile") or return -1;
open(OUT, ">$outfile") or return -2;
my @content =
\n";
open(INFILE, $infile) or die "$infile: $!";
open(OUTFILE, $outfile) or die "$outfile: $!";
my($line);
while(defined($line =
\n";
# [" . $a[$i] . "] to [" . $a[$i+1] . "]
\n";
}
$line =~ s/$a[$i]/$a[$i+1]/g;
}
print OUTFILE $line;
}
close(INFILE);
close(OUTFILE);
}
#==========================================
# require "mycgi.pl";
#
# &mycgi'PrintStringWithReplaced($str, $outfile, "{EMail}", $a, "{Code}", $b);
# ex. $infile = '-', 'a.in', $outfile="> a.out", ">> a.append", ">-"
#==========================================
sub PrintStringWithReplaced
{
my $narg = @_;
my @a = @_;
my $str = $a[0];
my $outfile = $a[1];
my($org,$target);
open(OUTFILE, $outfile) or die "$outfile: $!";
for(my $i = 2 ; $i < $narg ; $i += 2){
$str =~ s/$a[$i]/$a[$i+1]/g;
}
print OUTFILE $str;
close(OUTFILE);
}
#==========================================
# &mycgi'ConvertString($str, "{EMail}", $a, "{Code}", $b);
#==========================================
sub ConvertString
{
my $narg = @_;
my @a = @_;
my $str = $a[0];
for(my $i = 1 ; $i < $narg ; $i += 2){
$str =~ s/$a[$i]/$a[$i+1]/g;
}
return $_[0] = $str;
}
sub IsValidPassword
{
my ($password) = (@_);
if($password =~ /^[a-zA-Z0-9_]+$/){
return 1;
}
return 0;
}
sub IsValidEMailAddress
{
my ($email) = (@_);
if($email =~ /^[a-zA-Z0-9._\-+\%\$#!&~]+@[a-zA-Z0-9._\-+]+$/){
return 1;
}
return 0;
}
sub BuildDateString
{
my ($time) = (@_);
my ($sec, $min, $hour, $mday, $mon, $year,
$wday, $yday, $isdst) = localtime($time);
$year += 1900;
$mon++;
my $str = sprintf("%02d/%02d/%02d %02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
return $str;
}
sub GetFileSize
{
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($_[0]);
return $size;
}
sub GetWriteDate
{
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($_[0]);
return $mtime;
}
#==========================================
# DB subroutines
#==========================================
sub OpenDB
{
my ($DBServer, $DBUser, $DBPassword, $DBName) = @_;
my $db;
my $sth;
$db = DBI->connect('DBI:mysql:'.$DBName.':'.$DBServer, $DBUser, $DBPassword);
if(!$db){
print "Unable to connect to $DBName
\n";
return 0;
}
$sth = $db->prepare("use $DBName;\n");
my $result = $sth->execute;
if(!$result){
print "use: SQL execution error
\n";
return 0;
}
#print "db:$db $sth
\n";
return ($db,$sth);
}
sub CloseDB
{
my ($db, $sth) = @_;
$sth->finish;
$db->disconnect;
}
sub DBExecute
{
my ($db, $sth, $command) = @_;
$sth = $db->prepare($command);
my $ret = $sth->execute;
return ($sth,$ret);
}
#===============================================
# 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);
}
sub ConvertHTMLToFullURL
{
my ($Content, $SourceURL, $Debug) = (@_);
my $res;
my $ConvContent;
$res = $Content;
$ConvContent = "";
while(1) {
my $count =
($res =~ /^(.*?)(\
\n";
return -1;
}
$Content = $response->content;
&ConvertHTMLToFullURL($Content, $url, 0);
return $Content;
}
sub ExtractHTMLBody
{
my ($Content) = @_;
$Content =~ /\