#======================================================================================= # perl-lib.pl Version2004.05 Perl5 Only # Try The HomePage http://www.tryhp.net # Terra(info@tryhp.net) # -------------------------------------------------------------------------------- # [,????] = PossibilityOmission # # age(BirthdayString) # BirthdayString Format = 2001/05/09 # ascscramble(String,flag[,key]) # flag = 0:Decoding / 1:Encryption # key = 0 => 3600 Japanese Correspondence # calendar(Year, Month, Timelag, Flag) # [7 Days] # @CALENDAR = calendar('2001', '09', 9, 0); # Flag = 0:日,月,火,水,木,金,土 # 1:Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday # 2:Sun,Mon,Tue,Wed,Thu,Fri,Sat # calendar2(Year, Month, Timelag, Flag) # @CALENDAR = calendar('2001', '09', 9, 0); # Flag = 0:日,月,火,水,木,金,土 # 1:Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday # 2:Sun,Mon,Tue,Wed,Thu,Fri,Sat # changecsv(src, des, keys) # comma(number) # cookie_read(cookiename) # cookie_regist(cookiename,cookielist) # data_read(data_path) # data_save(data_path, WRITE_DATA) # dateserial(DateString, TimeLag) # $serial = dateserial("2001/05/10 11:55:57", 0); # $serial = 989463357 # domain([flag]) # flag = 0:Full Host Domain / 1:Domain # fcopy(src, des, permission) # src = srcfile # des = desfile # fields(fields[,Separator]) # Not Separator = "\t" # html_head(bgcolor,text,link,vlink,alink[,background,topmargin,leftmargin,title]) # hexstr(string,flag) # string = change string # flag = 0:16 To Chr # 1:Chr To 16 # ichr(string,flag) # string = change string # flag = 0:delete # 1:image # imagesize(imagefile) # imagefile = image file path # [Sample] # ($width, $height) = imagesize('img/test.jpg'); # img_head([flag]) # flag = gif / jpeg / png # inline_link(String[,Replacement]) # jst_time(SerialTime[,flag]) # flag = 0:2001年5月25日(金) 10:54:15 # 1:2001年5月25日(金) # 2:2001年5月25日 # 3:2001/5/25(Friday) 10:54:15 # 4:2001/5/25(Friday) # 5:2001/05/25 # kaconv(String) # progpass() # readparts([Variable, Tag, Jcode]) # Variable = VariableName # Tag = Ineffective Tag List # Jcode = Omission : Untransformation # jis, sjis, euc # rgb(Color) # (R,G,B) = rgb('#FF0AB6'); # scramble(String,flag[,key]) # flag = 0:Decoding / 1:Encryption # key = Ank 0 => 128, Japanese -16 => -16 # send_email(sendmailpath,uuencodepath,subject,from,to,cc,bcc,body[,files,encoding]) # [UNIX/Linux] # sendmailpath = '/usr/lib/sendmail' ? # uuencodepath = '/usr/bin/uuencode' ? # [Windows] # sendmailpath = 'c:\usr\lib/blatj.exe' ? # send_email(sendmailpath,'',subject,from,to,'','',body) # sumnail(imagefile, maxsize[, flag]) # imagefile = image file path # maxsize = Max image size # [Sample] # ($width, $height) = sumnail('img/test.jpg', 128); # ($width, $height) = sumnail('img/test.jpg', 128, 1); # sumnailcopy(srcfile, desfile, newwidth) # srcfile = Sauce image file path(GIF Onry) # desfile = Copy filename # newwidth = New image width # [Sample] # ($err) = sumnailcopy('img/test.gif', 'img/test2.gif', 80); # tag_change(string) # tag_check(string, FREETAGS) # FREETAGS = Permission TagList ('a','p','font','u','i','b') # upload(autoname,filetype,format,dir,max,permission,mode[,variable]) # [Example 1] # Indispensable cgi-lib.pl ReadParse(*QUERY) # UploadFileList = @QUERY # [Sample] # &ReadParse(*QUERY); # while (($key, $value) = each %QUERY) { # $key =~ /upload/i && next; # $value =~ s/\n//g; # $value =~ s//>/g; # &jcode'convert(*value,'sjis'); # $QUERY{$key} = $value; # } # [Example 2] # [Sample] # readparts ('QUERY', '<>=', 'sjis'); # autoname = 0:Original Filename / 1:Auto Filename # filetype = Mimetype # format = ImageType # dir = Save Directory # max = Max FileSize # permission = permission # mode = text:Windows TextFile -> UnixFile # variable = VariableName # user_agent() # whois(domain) # UNIX onry #======================================================================================= use Socket; use Cwd; use File::Copy; use Net::Ping; use Time::Local; #$CR = "\015\012"; $CR = "\n"; sub html_head { my($bgcolor, $text, $link, $vlink, $alink, $background, $topmargin, $leftmargin, $title, $fontsize, $border) = @_; if ($bgcolor eq '') { $bgcolor = '#FFFFFF'; } if ($text eq '') { $text = '#000000'; } if ($link eq '') { $link = '#0000FF'; } if ($vlink eq '') { $vlink = '#FF0000'; } if ($alink eq '') { $alink = '#00FF00'; } if ($topmargin eq '') { $topmargin = 10; } if ($leftmargin eq '') { $leftmargin = 10; } if ($fontsize eq '') { $fontsize = 10; } my($inpfont) = $fontsize - 1; $fontsize .= 'pt'; $inpfont .= 'pt'; print "Content-type: text/html\n\n"; print "\n"; print "$title\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; } #======================================================================================= sub img_head{ my($flag) = @_; !$flag && ($flag = 'gif'); print "Content-type: image/$flag\n\n"; } #======================================================================================= sub imodehead { my($title) = @_; print "Content-type: text/html\n\n"; print "\n"; print "$title\n"; print "\n"; print "\n"; print "\n"; print "\n"; } #======================================================================================= sub comma { local($_) = $_[0]; 1 while s/(.*\d)(\d\d\d)/$1,$2/; $_; } #======================================================================================= sub send_email { my($sendmailpath, $uuencodepath, $subject, $from, $to, $cc, $bcc, $body, $files, $encoding, $separator) = @_; my($mimeid, $err, $name, $status, $message, $option) = ''; ($sendmailpath, $option) = split(/ /, $sendmailpath); my(@ATTACH_FILES, @ENCODING, @ENCODE_DATA) = (); my(@TO) = split(/\,/, $to); my(@CC) = split(/\,/, $cc); my(@BCC) = split(/\,/,$bcc); my(@attach_files) = split(/\,/, $files); my(@encoding) = split(/\,/, $encoding); my($i, $filename, $tmpfile); !$separator && ($separator = ','); my($mailto) = ''; foreach (@TO) { if (/([\w\-\.]+\@[\w\-\.]+)/) { if ($mailto) { $mailto .= "$separator$1"; } else { $mailto = $1; } } } if ($mailto eq '') { return(); } $cc = ''; foreach (@CC) { if (/([\w\-\.]+\@[\w\-\.]+)/) { if ($cc) { $cc .= "$separator$1"; } else { $cc = $1; } } } $bcc = ''; foreach (@BCC) { if (/([\w\-\.]+\@[\w\-\.]+)/) { if ($bcc) { $bcc .= "$separator$1"; } else { $bcc = $1; } } } if (!$mailto) { return('Err NotMailAddress'); } if ($sendmailpath =~ /blatj/i) { $tmpfile = "$$\.tmp"; if (open(TMP,">$tmpfile")) { print TMP $body; close(TMP); } else { return('bad New TemporaryFile'); } if ($cc) { $cc = " -c $cc"; } if ($bcc) { $bcc = " -b $bcc"; } $files =~ s/\//\\/g; if (-f $files && $encoding eq 'text') { $attach = " -attacht $files"; } if (-f $files && $encoding eq 'base64') { $attach = " -base64 -attach $files"; } if (-f $files && $encoding eq 'uuencode') { $attach = " -uuencode -attach $files"; } if (-f $files && $encoding eq 'mime') { $attach = " -mime -attach \"$files\""; } if (open(MAIL,"| $sendmailpath $tmpfile -s \"$subject\" -f $from -t $mailto$cc$bcc$attach -q")) { close(MAIL); } else { $err = 'Error Open sendmail Failure'; } unlink $tmpfile; } elsif (-e $sendmailpath) { $option eq '-to' && ($sendmailpath .= " $mailto"); for ($i = 0; $i < @attach_files; ++$i) { if (!(-e $attach_files[$i])) { $err = "$attach_files[$i] does not exist."; return($err); } push(@ATTACH_FILES, $attach_files[$i]); push(@ENCODING, $encoding[$i]); } if ($encoding =~ /mime/i) { $mimeid = 'perl-lib_pl_send_email_-' . time; } if (open(MAIL,"| $sendmailpath -t")) { binmode MAIL; print MAIL "From: $from$CR"; print MAIL "To: $mailto$CR"; print MAIL "Cc: $cc$CR" if $cc; print MAIL "Bcc: $bcc$CR" if $bcc; print MAIL "Subject: $subject$CR"; if ($mimeid) { print MAIL "x-sender: $from$CR"; print MAIL "x-mailer: perl-lib$CR"; print MAIL "Mime-Version: 1.0$CR"; print MAIL "Content-Type: multipart/mixed; boundary=\"$mimeid\"$CR"; print MAIL "--$mimeid$CR"; print MAIL "Content-Type: text/plain; charset=\"iso-2022-jp\"$CR$CR"; #print MAIL "Content-transfer-encoding: quoted-printable$CR$CR"; } else { print MAIL $CR; } print MAIL $body; print MAIL $CR; for ($i = 0; $i < @ATTACH_FILES; ++$i) { $attach_file = $ATTACH_FILES[$i]; $encoding = $ENCODING[$i]; $attach_file =~ /[\\\/:]([^\\\/:]+)$/g; $filename = $1; if (-e $attach_file) { if ($encoding eq 'uuencode') { print MAIL "Attachment:\t$filename$CR"; print MAIL "Encoding:\tUUEncoded$CR"; if ($uuencodepath && -e $uuencodepath) { if (open(FIL,"$uuencodepath $attach_file $filename |")) { @ENCODE_DATA = ; close(FIL); print MAIL @ENCODE_DATA; } else { $err = 'Error Not Open uuencode'; } } else { $encode_data = &changeuuencode($attach_file); print MAIL "begin 644 $filename\n"; print MAIL $encode_data; print MAIL "`\nend\n\n"; } } elsif ($encoding eq 'mime') { print MAIL "--$mimeid$CR"; if (-T $attach_file) { print MAIL "Content-type: text/plain; charset=iso-2022-jp; name=\"$filename\"$CR"; } else { if ($filename =~ /\.jpg/i || $filename =~ /\.jpeg/i) { print MAIL "Content-type: image/jpeg; name=\"$filename\"$CR"; } elsif ($filename =~ /\.gif/i) { print MAIL "Content-type: image/gif; name=\"$filename\"$CR"; } elsif ($filename =~ /\.png/i) { print MAIL "Content-type: image/png; name=\"$filename\"$CR"; } else { print MAIL "Content-type: application/octet-stream; name=\"$filename\"$CR"; } } print MAIL "Content-transfer-encoding: base64$CR$CR"; $encode_data = &changebase64($attach_file); print MAIL "$encode_data$CR"; } else { if (open(TEXT, $attach_file)) { print MAIL "Attachment:\t$filename$CR"; print MAIL "Encoding:\tNone$CR$CR"; while () { s/^\.([\n\r\f]+)/..$1/; print MAIL } close(TEXT); print MAIL "\n\n"; } } } } if ($mimeid) { print MAIL "--$mimeid--$CR" } print MAIL "$CR.$CR"; close(MAIL); } else { $err = 'Error Open sendmail Failure'; } } else { $err = 'Error Not sendmail Utility'; } $err; } #======================================================================================= sub changeuuencode { my($file, $flag) = @_; my($encode, $line); if ($flag) { if (open(FIL, $file)) { while () { $encode .= unpack("u", $_); } close(FIL); } } else { if (open(FIL, $file)) { while (read(FIL, $line, 45)) { $encode .= pack("u", $line); } close(FIL); } } $encode; } #======================================================================================= sub changebase64 { my($file) = $_[0]; my($encode, $line) = ''; my($len, $bytes, $pad) = 0; if (open (FIL, "<$file")) { while ($bytes = read(FIL, $line, 45)) { $len += $bytes; $encode .= substr(pack('u', $line), 1); chop($encode); } close(FIL); $encode =~ tr| -_`|A-Za-z0-9+/A|; $pad = (3 - ($len % 3)) % 3; substr($encode, -$pad, $pad) = '=' x $pad; $encode =~ s/(.{76})/$1\n/g; } $encode; } #======================================================================================= sub base64 { my($str) = $_[0]; my($encode, $line) = ''; my($len, $bytes, $pad, $i) = 0; $len = length($str); while ($i <= $len-1) { $line = substr($str, $i, 45); $i += length($line); $encode .= substr(pack('u', $line), 1); chop($encode); } $encode =~ tr| -_`|A-Za-z0-9+/A|; $pad = (3 - ($len % 3)) % 3; substr($encode, -$pad, $pad) = '=' x $pad; $encode =~ s/(.{76})/$1\n/g; $encode; } #======================================================================================= sub iso2022 { local($str) = @_; jcode'convert(*str,'jis'); $str= "=?iso-2022-jp?B?" . base64($str) . "?="; $str; } #======================================================================================= sub subjectiso2022 { my($str) = @_; my($max) = klength($str); my($subject, $s); my($i) = 0; while ($i <= $max - 1) { $s = ksubstr($str, $i, 18); $i += klength($s); if ($subject) { $subject .= " " . iso2022($s); } else { $subject = iso2022($s); } } $subject; } #======================================================================================= sub decode { my($str) = $_[0]; my($encode, $j) = ''; my($len, $i) = 0; $len = length($str); foreach (0 .. $len-1) { $j = substr($str, $_, 1); ($j ne '=' && $j ne '&') && ($j = '%' . unpack('H2', $j)); $encode .= $j; } $encode; } #======================================================================================= sub data_read { my($data_path) = @_; my(@READ_DATA); if (open(DB,"$data_path")) { @READ_DATA = ; close(DB); } @READ_DATA; } #======================================================================================= sub dblock { my($file) = @_; if (!-e $file) { return; } my($lockfile) = $file . '.lock'; my($error, $tmpflag); if (-e $lockfile) { my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($lockfile); time - $mtime > 180 && unlink $lockfile; foreach (1 .. 10) { unless (-f $lockfile) { $tmpflag = 1; last; } sleep(1); } } else { $tmpflag = 1; } if (!$tmpflag || !link($file, $lockfile)) { $error = 'Bad File Lock' }; $error; } #======================================================================================= sub dbunlock { my($file) = @_; my($lockfile) = $file . '.lock'; -e $lockfile && unlink $lockfile; } #======================================================================================= sub data_save { my($data_path, @WRITE_DATA) = @_; my($err) = ''; my($os) = &os(); my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks); $data_path =~ /(.+)\..+$/; my($filename) = $1; my($date) = time + $timelag * 3600; if ($filename !~ /.+/) { $err = 'bad Filename(Not Extension?)'; } if (!$err) { my($tmpfile) = "$filename.tmp"; my($tmpflag) = 0; foreach (1 .. 10) { unless (-f $tmpfile) { $tmpflag = 1; last; } ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($tmpfile); if ($date - $mtime > 600) { unlink $tmpfile; $tmpflag = 1; last; } $tmpflag = 0; sleep(1); } if ($tmpflag) { $tmp_dummy = "$$\.tmp"; if (!open(TMP,">$tmp_dummy")) { $err = 'bad New TemporaryFile'; } if (!$err) { close(TMP); chmod 0666,$tmp_dummy; if (!open(TMP,">$tmp_dummy")) { $err = 'bad New TemporaryFile'; } if (!$err) { binmode TMP; print TMP @WRITE_DATA; close(TMP); foreach (1 .. 10) { unless (-f $tmpfile) { if (!open(TMP,">$tmpfile")) { $err = 'bad LockFile System'; last; } if (!$err) { close(TMP); $os =~ /windows/i && unlink $data_path; rename($tmp_dummy, $data_path); unlink $tmpfile; last; } } sleep(1); } } } } } $err; } #======================================================================================= sub upload { my($autoname, $ftype, $fmt, $dir, $max, $permission, $mode, $japanese, $variable) = @_; !$variable && ($variable = 'QUERY'); my(@UPLOADFILES); my(@UPLOAD) = grep(/filename=\"(.+)\"\s*Content\-Type:/, @$variable); my($name, $localpath, $filename, $fname, $filepath, $ext, $filetype, $format, $writeflag, $err); if ($permission < 604) { $permission = 644; } $permission = sprintf("%04d", $permission); if ($dir && $dir !~ /\/$/) { $dir .= "/"; } my($uploadfiles) = 0; foreach (@UPLOAD) { $writeflag = 0; $err = ''; if ($japanese) { # 日本語ファイル名使用可能 /name=\"(.*)\";\sfilename=\"((.*\\|)(.+))\"\s*Content\-Type:\s*(.*)\/(.*)/i; $name = $1; $localpath = $2; $filename = $4; $filetype = $5; $format = $6; } else { # 日本語ファイル名使用不可 /name=\"(.*)\";\sfilename=\"((.*\\|)([\w-\.]*))\"\s*Content\-Type:\s*(.*)\/(.*)/i; $name = $1; $localpath = $2; $filename = $4; $filetype = $5; $format = $6; } if ($filename =~ /(.*)\.(.*)/) { $fname= $1; $ext = $2; } else { $fname = $filename; $format =~ s/pjpeg/jpg/; $ext = $format; $filename .= "\.$ext"; } $filename =~ s/\ /\_/g; if ($filename eq '') { $err = 'Bad FileName'; } if ($ftype) { if ($ftype =~ /$filetype/i) { if ($fmt) { if ($format =~ /$fmt/i) { $writeflag = 1; } else { $writeflag = 0; $err = 'bad ImageType(jpeg,gif,png)'; } } else { $writeflag = 1; } }else { $writeflag = 0; $err = 'bad FileType'; } } else { $writeflag = 1; } if ($max) { if (length($$variable{$name}) > $max) { $writeflag = 0; $err = 'bad Max FileSize'; } } if ($writeflag && !$err) { if ($autoname) { $sys = abs($$) + $uploadfiles; $filename = time . "$sys\.$ext"; } $filepath = "$dir$filename"; if (-f $filepath) { chmod(0666, $filepath); } if ($mode =~ /text/i) { $$variable{$name} =~ s/\r\n/\n/g; } if (open(FIL, ">$filepath")) { binmode FIL; print FIL $$variable{$name}; close FIL; chmod(eval($permission), $filepath); } } push(@UPLOADFILES, "name=$name\tlocal=$localpath\tfilename=$filename\tfiletype=$filetype\tformat=$format\terr=$err"); $uploadfiles++; } if (@UPLOADFILES < 1) { push(@UPLOADFILES, "name=\tlocal=\tfilename=\tfiletype=\tformat=\terr=UploadFile Not Select"); } @UPLOADFILES; } #======================================================================================= sub getimagetype { my($img) = @_; my($type) = substr($img, 0, 24); if ($type =~ /jfif/i || $type =~ /exif/i) { $type = 'JPG'; } elsif ($type =~ /gif/i) { $type = 'GIF'; } elsif ($type =~ /BM/) { $type = 'BMP'; } elsif ($type =~ /PNG/) { $type = 'PNG'; } else { $type = ''; } $type; } #======================================================================================= sub imagesize { my($img) = @_; my($width, $height, $buffer, @DUMMY, $flag); if (open(IMG, "$img")) { binmode IMG; read(IMG, $type, 16); seek(IMG, 0, 0); if ($type =~ /jfif/i || $type =~ /exif/i) { $type = 'JPG'; seek(IMG, 2, 0); while (!eof(IMG)) { read(IMG, $buffer, 4); @DUMMY = unpack("aan", $buffer); if (ord($DUMMY[0]) != 255) { $width = 0; $height = 0; last; } elsif (ord($DUMMY[1]) >= 192 && ord($DUMMY[1]) <= 195) { read(IMG, $buffer, 5); ($height, $width) = unpack("xnn", $buffer); last; } else { read(IMG, $buffer, ($DUMMY[2] - 2)); } } } elsif ($type =~ /gif/i) { $type = 'GIF'; seek(IMG, 6, 0); read(IMG, $buffer, 4); @DUMMY = unpack("C"x 4, $buffer); $width = $DUMMY[1] * 256 + $DUMMY[0]; $height = $DUMMY[3] * 256 + $DUMMY[2]; } elsif ($type =~ /^BM/) { $type = 'BMP'; seek( IMG, 18, 0 ); read( IMG, $buffer, 8 ); ($width, $height) = unpack("LL", $buffer); } elsif ($type =~ /PNG/) { $type = 'PNG'; seek(IMG, 0, 0); read(IMG, $buffer, 24); ($width, $height) = unpack("x16 NN", $buffer); if (!$width && !$height) { seek(IMG, 8, 0); while(1){ read(IMG, $buffer, 8 ); ($offset, $flag) = unpack("NA4", $buffer); if($flag eq 'IHDR'){ read(IMG, $buffer, 8); ($width, $height) = unpack("NN", $buffer); last; } elsif ($flag eq 'IEND' ){ $type= ''; $width = 0; $height = 0; last; } else { seek(IMG, $offset + 4, 1); } } } } else { return(0, 0); } close(IMG); return($width, $height, $type); } else { return(0, 0); } } #======================================================================================= sub sumnail { my($img, $maxsize, $flag) = @_; my($width, $height) = &imagesize($img); if ($width == 0 || $height == 0) { return(0, 0); } my($new_width, $new_height, $rate); if ($flag && $width <= $maxsize && $height <= $maxsize) { $new_width = $width; $new_height = $height; } else { if ($width >= $height) { $rate = $height / $width; $new_width = $maxsize; $new_height = int($maxsize * $rate); } else { $rate = $width / $height; $new_width = int($maxsize * $rate); $new_height = $maxsize; } } return($new_width, $new_height, $width, $height); } #======================================================================================= sub sumnailcopy { my($FLY, $srcfile, $desfile, $newsize, $flag) = @_; !-e $srcfile && return('404 file not fund'); if ($FLY eq 'GD') { # GD Graphic my($width, $height); open (IMG, "Skyline.jpg"); my($image) = newFromJpeg GD::Image(\*IMG) || die "Couldn't read GIF data!"; close IMG; my($srcwidth, $srcheight) = $image->getBounds(); if ($flag && $srcwidth < $srcheight) { $width = $srcwidth / $srcheight * $newsize; $height = $newsize; } else { $width = $newsize; $height = $srcheight / $srcwidth * $newsize; } my($image2) = new GD::Image($width,$height); $image2->copyResized($image,0,0,0,0,$width,$height,$srcwidth, $srcheight); open (OUT, ">$desfile"); binmode(OUT); print OUT $image2->jpeg; close(OUT); } elsif ($FLY eq 'ImageMagick') { # ImageMagick my($obj) = Image::Magick->new; $obj->Read($srcfile); my($width, $height) = $obj->get('width', 'height'); if ($width == 0 && $height == 0) { return('404 file not fund'); } if ($width < $newsize && $height < $newsize) { fcopy($srcfile, $desfile, 666); return(); } if ($flag && $height > $width) { $newsize = int($newsize * ($width / $height) + 0.5); } $obj = $obj->Transform(geometry=>$newsize); if ($desfile =~ /\.gif/i) { $obj->Write("gif:$desfile"); } elsif ($desfile =~ /\.png/i) { $obj->Write("png:$desfile"); } else { $obj->Write("jpeg:$desfile"); } } else { # on the fly my($newwidth, $newheight); if ($FLY && (-e $FLY || -e "$FLY.exe")) { if ($srcfile && -f $srcfile && $desfile && $newsize) { my($width, $height) = imagesize($srcfile); if ($width == 0 && $height == 0) { return('404 file not fund'); } if ($flag && $height > $width) { $newwidth = int($newsize * ($width / $height) + 0.5); $newheight = $newsize; } else { $newwidth = $newsize; $newheight = int($height / ($width / $newsize) + 0.5); } my($infile) = "$$.tmp"; open(FLY,"> $infile"); print FLY "new\n"; print FLY "size $newwidth, $newheight\n"; print FLY "copyresized -1,-1,-1,-1,0,0,$newwidth,$newheight,$srcfile\n"; close(FLY); open(IMG,"| $FLY -o $desfile -i $infile -q"); close(IMG); open(IMG,"$outfile"); binmode(IMG); binmode(STDOUT); print $_ while (); close(IMG); unlink($infile); return(); } else { return('Abnormal Parameter'); } } else { return("Graphic Utility not [On The Fly] $FLY"); } } } #======================================================================================= sub tag_change { $_ = $_[0]; s/&eq;/=/g; 1 while s/(.*)(<(img([!-:A-~\s\=]+))>)/$1/i; 1 while s/(.*)(<(b)>(.*)<\/b>)/$1$4<\/b>/i; 1 while s/(.*)(<(u)>(.*)<\/u>)/$1$4<\/u>/i; 1 while s/(.*)(<(i)>(.*)<\/i>)/$1$4<\/i>/i; 1 while s/(.*)(<(font[\s\w\=\#\"\']+)\>(.*)\<\/font\>)/$1<$3>$4<\/font>/i; $_; } #======================================================================================= sub tag_check { local($_, @FREETAGS) = @_; my(%SINGLETAGS) = ('input',1,'br',1,'hr',1,'img',1,'meta',1); my(@TAGS, @REVTAGS, @OPENTAGS, @CLOSETAGS); my($tagname, $match, $word, $i, $string, $opentags, $closetags); s/<//g; s/&eq;/=/g; # s/\r//ig; s///g; if (/\)/i) { $tagname = $2; $tagname=~ tr/[A-Z]/[a-z]/; if (grep(/$tagname/, @FREETAGS)) { push(@CLOSETAGS, ""); } } } !$TAGS[0] && shift(@TAGS); foreach (@TAGS) { if (/>/) { $_ = "<$_"; $match = 0; if (/<(\w+)/i) { $word = $1; $word =~ tr/[A-Z]/[a-z]/; push(@OPENTAGS,"<$word\>"); foreach $tag (@FREETAGS) { if ($word eq $tag) { if ($SINGLETAGS{$word}) { $match = 1; } else { $i = 0; foreach $closetag (@CLOSETAGS) { if ($closetag eq "<\/$word>") { $match = 1; last; } $i++; } if ($match) { splice(@CLOSETAGS, $i, 1); } } } } } else { if (/<\/(\w+)>/i) { $word = $1; $word =~ tr/[A-Z]/[a-z]/; if (!grep(/$word/, @FREETAGS)) { s/<\/$word>//g; $match = 1; } else { $i = 0; foreach $opentag (@OPENTAGS) { if ($opentag eq "<$word>") { $match = 1; last; } $i++; } if ($match) { splice(@OPENTAGS, $i, 1); } } } else { $match = 1; } } } else { s/[!-:A-~\s\=]+//; $match = 1; } #if (!$match) { s/[<>!-:A-~\s\=\"\;]+//; } if (!$match) { s/<.*>//; } $string .= $_; } } else { $string = $_; } $string =~ s/\t//g; $string =~ s/\n\n//g; $string =~ s/\r\r//g; $string; } #======================================================================================= sub inline_link { local($_, $string, $target) = @_; $target && ($target = " target=$target"); if ($string) { s/([^=^\"]|^)((http|ftp):[!#-9A-~?=]+)/$1$string<\/a>/g; } else { s/([^=^\"]|^)((http|ftp):[!#-9A-~?=]+)/$1$2<\/a>/g; } s/([\w\-\_\.]+\@[\w\-\_\.]+)/$1<\/a>/g; $_; } #======================================================================================= sub domain { local($flag) = @_; local($addr) = $ENV{'REMOTE_ADDR'}; local($_) = gethostbyaddr(pack("C4",split(/\./,$addr)),2); if ($_ eq '') { $_ = $addr; } else { if ($flag) { if (/.+\.(.+)\.(.+)\.(.+)$/) { $_ = "\*\.$1\.$2\.$3"; } elsif (/.+\.(.+)\.(.+)$/) { $_ = "\*\.$1\.$2"; } elsif (/.+\.(.+)$/) { $_ = "\*\.$1"; } else { $_ = "on the internet"; } } } $_; } #======================================================================================= sub user_agent { $_ = $ENV{'HTTP_USER_AGENT'}; s/,/./g; s//>/g; $_; } #======================================================================================= sub jst_time { my($serialtime, $flag) = @_; my(@DATE) = localtime($serialtime); $DATE[5] += 1900; $DATE[4]++; if ($flag == 0 || $flag == 1 || $flag == 2) { $DATE[6] = ('日','月','火','水','木','金','土') [$DATE[6]]; if ($flag == 0) { $_ = "$DATE[5]年$DATE[4]月$DATE[3]日($DATE[6]) $DATE[2]:$DATE[1]:$DATE[0]"; } elsif ($flag == 1) { $_ = "$DATE[5]年$DATE[4]月$DATE[3]日($DATE[6])"; } else { $_ = "$DATE[5]年$DATE[4]月$DATE[3]日"; } } else { $DATE[6] = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday') [$DATE[6]]; if ($flag == 3) { $_ = "$DATE[5]/$DATE[4]/$DATE[3]($DATE[6]) $DATE[2]:$DATE[1]:$DATE[0]"; } elsif ($flag == 4) { $_ = "$DATE[5]/$DATE[4]/$DATE[3]($DATE[6])"; } elsif ($flag == 5) { $_ = sprintf("%04d/%02d/%02d", $DATE[5], $DATE[4], $DATE[3]); } elsif ($flag == 6) { $_ = "$DATE[5]/$DATE[4]/$DATE[3] $DATE[2]:$DATE[1]"; } elsif ($flag == 7) { $_ = "$DATE[5]/$DATE[4]/$DATE[3] $DATE[2]:$DATE[1]:$DATE[0]"; } elsif ($flag == 8) { $_ = sprintf("%04d%02d%02d%02d%02d%02d", $DATE[5],$DATE[4],$DATE[3],$DATE[2],$DATE[1],$DATE[0]); } else { $_ = sprintf("%02d/%02d %02d:%02d", $DATE[4], $DATE[3], $DATE[2], $DATE[1]); } } } #======================================================================================= sub gengo { my($serialtime, $flag, $fmt) = @_; if ($flag) { my($year, $month, $day) = split(/\//, $serialtime); if ($flag =~ /h/i) { $year += 1988; } elsif ($flag =~ /s/i) { $year += 1925; } elsif ($flag =~ /t/i) { $year += 1911; } elsif ($flag =~ /m/i) { $year += 1867; } sprintf("%04d/%02d/%02d", $year, $month, $day); } else { my($jst) = &jst_time($serialtime, 5); my(@DATE) = localtime($serialtime); my($gengo, $year); $DATE[5] += 1900; $DATE[4]++; $DATE[6] = ('日','月','火','水','木','金','土') [$DATE[6]]; if ($jst ge "1989/01/08") { $gengo = '平成'; $year = $DATE[5] - 1988; } elsif ($jst ge "1926/12/25") { $gengo = '昭和'; $year = $DATE[5] - 1925; } elsif ($jst ge "1912/07/30") { $gengo = '大正'; $year = $DATE[5] - 1911; } elsif ($jst ge "1868/09/08") { $gengo = '明治'; $year = $DATE[5] - 1867; } if ($fmt) { sprintf("%s$fmt",$gengo,$year,$DATE[4],$DATE[3],$DATE[6]); } else { "$gengo$year年$DATE[4]月$DATE[3]日($DATE[6])"; } } } #======================================================================================= sub dateserial { my($date, $timelag) = @_; my(@DATE, @TIME, $time, $year, $day); ($date, $time) = split(/ /, $date); if ($date =~ /(\d+)\D+(\d+)\D+(\d+)/) { $DATE[0] = $1; $DATE[1] = $2; $DATE[2] = $3; } else { return(0); } if ($time =~ /(\d+)\D+(\d+)\D+(\d+)/) { $TIME[0] = $1; $TIME[1] = $2; $TIME[2] = $3; } $year = $DATE[0] - 1970; if ($year < 0) { return(0); } $DATE[1]--; $DATE[2]--; foreach (1 .. $DATE[1]) { if ($_ == 4 || $_ == 6 || $_ == 9 || $_ == 11) { $day += 30; } elsif ($_ == 2) { if ($DATE[0] % 4 == 0) { $day += 29; } else { $day += 28; } } else { $day += 31; } } $day = $day + $DATE[2] + int(($DATE[0] - 1972) / 4 + 0.9); $year * 31536000 + $day * 86400 + $TIME[0] * 3600 + $TIME[1] * 60 + $TIME[2]; } #======================================================================================= sub calendar { my($year, $month, $timelag, $flag) = @_; $year += 0; $month += 0; my($date) = "$year/$month/1"; my(@DATE) = localtime(dateserial($date, $timelag)); my(@CALENDAR, $days, $i, $j); if ($month == 4 || $month == 6 || $month == 9 || $month == 11) { $days = 30; } elsif ($month == 2) { if ($year % 4 == 0) { $days = 29; } else { $days = 28; } } else { $days = 31; } if ($flag == 1) { $CALENDAR[0] = 'Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday'; } elsif ($flag == 2) { $CALENDAR[0] = 'Sun,Mon,Tue,Wed,Thu,Fri,Sat'; } else { $CALENDAR[0] = '日,月,火,水,木,金,土'; } $j = 0; foreach (0 .. $DATE[6] - 1) { if ($_ == 0) { $CALENDAR[1] = ' '; } else { $CALENDAR[1] .= ', '; } } $i = 1; $j = $DATE[6]; foreach (1 .. $days) { if ($j == 0) { $CALENDAR[$i] = $_; } else { $CALENDAR[$i] .= ",$_"; } $j++; if ($j > 6) { $j = 0; $i++; } } if ($j > 0) { foreach ($j .. 6) { $CALENDAR[$i] .= ', '; } } @CALENDAR; } #======================================================================================= sub calendar2 { my($year, $month, $timelag, $flag, $return) = @_; my($date) = "$year/$month/1"; my(@DATE) = localtime(dateserial($date, $timelag)); my(@CALENDAR, $days, $j, $y, $m, $d); if ($month == 4 || $month == 6 || $month == 9 || $month == 11) { $days = 30; } elsif ($month == 2) { if ($year % 4 == 0) { $days = 29; } else { $days = 28; } } else { $days = 31; } if ($return) { return $days; } if ($flag) { if ($flag == 2) { @WEEK = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); } else { @WEEK = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'); } $y = '/'; $m = '/'; $d = ''; } else { @WEEK = ('日','月','火','水','木','金','土'); $y = '年'; $m = '月'; $d = '日'; } $j = $DATE[6]; $year = sprintf("%04d", $year); $month = sprintf("%02d", $month); foreach (1 .. $days) { $_ = sprintf("%02d", $_); $CALENDAR[$_] = "$year$y$month$m$_$d($WEEK[$j])"; $j++; if ($j > 6) { $j = 0; } } @CALENDAR; } #======================================================================================= sub progpass { my($flag) = $_[0]; my($s, @st); srand(time|$$); if ($flag =~ /N/i) { for ($i = 0; $i < 8; $i++) { $s .= (int(rand(9)) + 1); } } else { for ($i = 0; $i <= 3; $i++) { $st[$i] = int(rand(26)) + 97; } $s = pack("c4",$st[0],$st[1],$st[2],$st[3]); srand; for ($i = 0; $i <= 3; $i++) { $s .= (int(rand(9)) + 1); } } $s; } #======================================================================================= sub asciirtf { local($_) = @_; my($length) = length($_); my($index, $str, $j); for($index = 0; $index < $length; $index++) { $j = substr($_, $index, 1); $code = unpack("H2", $j); $str .= "\\'$code"; } $str; } #======================================================================================= sub ascscramble { local($_, $flag, $key, $addr) = @_; my($index, $j, $u_class, $d_class, $code, $length, $str); my(@ASC) = ('-','a'..'m','5'..'9','A'..'M','_','n'..'z','0'..'4','N'..'Z'); if (!$addr) { my(@ADDR) = split(/\./, $ENV{'SERVER_ADDR'}); foreach (@ADDR) { $addr += $_; } !$addr && ($addr = 128);#127.0.0.1 } $key += $addr; if ($_ && $key) { if ($flag) { $length = length($_); for($index = 0; $index < $length; $index++) { $j = substr($_, $index, 1); $code = unpack("C", $j) + $key; $u_class = int($code / 64); $d_class = $code % 64; $str .= "$ASC[$u_class]$ASC[$d_class]"; } $_ = $str; } else { $fix = int($key / 64); s/(.{1})(.{1})/"\0". ((ascno($1, @ASC) - $fix) * 64 + (ascno($2, @ASC) - $key % 64))/eg; s/\0(\d+)/pack("C", $1)/eg; } } $_; } sub chengeuid { local($_, $flag) = @_; my($index, $j, $u_class, $d_class, $code, $length, $str); my(@ASC) = reverse('-','_','a'..'z','0'..'9','A'..'Z'); if ($_) { if ($flag) { $length = length($_); for($index = 0; $index < $length; $index++) { $j = substr($_, $index, 1); $code = unpack("C", $j); $u_class = int($code / 64); $d_class = $code % 64; $str .= "$ASC[$u_class]$ASC[$d_class]"; } $_ = $str; } else { s/(.{1})(.{1})/"\0". (ascno($1, @ASC) * 64 + (ascno($2, @ASC) - % 64))/eg; s/\0(\d+)/pack("C", $1)/eg; } } $_; } sub ascno { my($chr, @ASC) = @_; my($code); foreach (0 .. @ASC - 1) { if ($chr eq $ASC[$_]) { $code = $_; last; } } $code; } #======================================================================================= sub scramble { local($_, $flag, $key, $noins) = @_; local($index, $j, $class, $u_class, $d_class, $code, $length, $str, $create, $match); if ($_) { my(@INSERT); if (!$noins) { if ($key =~ /\d+/) { $create = abs($key); $length = length($create); for($index = 0; $index < $length; $index++) { $code = substr($create, $index, 1); if (grep(/$code/, @INSERT) < 1) { push(@INSERT, $code); } } @INSERT = sort(@INSERT); if ($key > 8649) { $key = $key % 8649; } } } if ($flag) { $length = length($_); for($index = 0; $index < $length; $index++) { $j = substr($_, $index, 1); $code = unpack("C", $j) + $key; $u_class = int($code / 93) + 33; $d_class = $code % 93 + 33; $str .= "\0$u_class\0$d_class"; } $str =~ s/\0(\d+)/pack("C", $1)/eg; $length = length($str); $_ = ''; srand(time|$$); for ($index = 0; $index <= $length; $index++) { foreach $j (@INSERT) { if ($index == $j) { shift(@INSERT); $_ .= pack("C", int(rand(93)) + 33); last; } } $_ .= substr($str, $index, 1); } s/=/ /g; } else { s/ /=/g; $length = length($_); $index = 0; $str = ''; foreach (@INSERT) { $_ += $index; $index++; } for ($index = 0; $index <= $length; $index++) { $match = 0; foreach $j (@INSERT) { if ($index == $j) { shift(@INSERT); $match = 1; last; } } if (!$match) { $str .= substr($_, $index, 1); } } $_ = $str; s/(.{1})(.{1})/"\0". ((unpack("C", $1) - 33) * 93 + (unpack("C", $2) - 33 - $key))/eg; s/\0(\d+)/pack("C", $1)/eg; } } $_; } #======================================================================================= sub cookie_regist { my($cookiename, $cookielist, $date) = @_; !$date && ($date = 30); my(@COOKIELIST) = split(/\,/, $cookielist); my(%COOK); my(@DATE) = localtime(time + $date * 86400); $DATE[5] += 1900; $DATE[3] = sprintf("%02d",$DATE[3]); $DATE[2] = sprintf("%02d",$DATE[2]); $DATE[1] = sprintf("%02d",$DATE[1]); $DATE[0] = sprintf("%02d",$DATE[0]); my($wday) = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday') [$DATE[6]]; my($month) = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec') [$DATE[4]]; my($date_gmt) = "$wday, $DATE[3]\-$month\-$DATE[5] $DATE[2]:$DATE[1]:$DATE[0] GMT"; my($cookievalue, $key, $value); foreach (@COOKIELIST) { ($key, $value) = split(/=/, $_); $key =~ s/\,/&comma/g; $key =~ s/:/&colon/g; $key =~ s/;/&semicolon/g; $value =~ s/\,/&comma/g; $value =~ s/:/&colon/g; $value =~ s/;/&semicolon/g; if ($cookievalue) { $cookievalue .= ",$key:$value"; } else { $cookievalue = "$key:$value"; } $COOK{$key} = $value; } print "Set-Cookie: $cookiename=$cookievalue; expires=$date_gmt\n"; %COOK; } #======================================================================================= sub cookie_read { my($cookiename) = @_; my($key, $value, %COOK); my($cookies) = $ENV{'HTTP_COOKIE'}; my(@pairs) = split(/;/,$cookies); my(@DUMMY); foreach $pair (@pairs) { ($key, $value) = split(/=/, $pair); $key =~ s/ //g; $DUMMY{$key} = $value; } @pairs = split(/\,/,$DUMMY{$cookiename}); foreach $pair (@pairs) { ($key, $value) = split(/:/, $pair); $key =~ s/&comma/\,/g; $key =~ s/&colon/\:/g; $key =~ s/&semicolon/\;/g; $value =~ s/&comma/\,/g; $value =~ s/&colon/\:/g; $value =~ s/&semicolon/\;/g; $COOK{$key} = $value; } %COOK; } #======================================================================================= sub age { my($date, $timelag) = @_; my($year, $month, $day) = split(/\//, $date); my(@DATE) = localtime(time + $timelag * 3600); $DATE[5] += 1900; $DATE[4]++; my($age) = $DATE[5] - $year; if ($month > $DATE[4]) { $age--; } elsif ($month == $DATE[4]) { if ($day > $DATE[3]) { $age--; } } $age; } #======================================================================================= sub kaconv { my($string) = @_; my($len) = klength($string); my($str) = ''; for ($i=0;$i < $len;$i++) { $str .= kaconv2(ksubstr($string, $i, 1)); } $str; } sub kaconv2 { my($string) = @_; my($i, $j, $unpack, $pack); my($length) = length($string); local($_); for($i = 0; $i < $length; $i++) { $j = substr($string, $i, 1); $_ .= "!". unpack("C", $j); } my(@ASCII) = ('64-32', '73-33', '104-34', '148-35', '144-36', '147-37', '149-38', '102-39', '105-40', '106-41', '150-42', '123-43', '67-44', '124-45', '68-46', '94-47', '70-58', '71-59', '131-60', '129-61', '132-62', '72-63', '151-64', '109-91', '143-92', '110-93', '79-94', '81-95', '111-123', '98-124', '112-125', '96-126' ); foreach $ascii (@ASCII) { ($unpack, $pack) = split(/\-/, $ascii); s/!129!$unpack/!$pack/g; } while (/(^|!(\d+))!130!(\d+)/) { if (($3 >= 63 && $3 <= 88)||($3 >= 96 && $3 <= 121)) { $st = $3 - 31; $_ =~ s/!130!(\d+)/!$st/; } elsif ($3 >= 129 && $3 <= 154 && $2 < 129) { $st = $3 - 32; $_ =~ s/!130\!(\d+)/!$st/; } else { $_ =~ s/!130!(\d+)/;130!$1/; } } s/;(\d+)/pack("C", $1)/eg; s/!(\d+)/pack("C", $1)/eg; s/、/,/g; $_; } #======================================================================================= sub fields { my($fields, $separator) = @_; !$separator && ($separator = "\t"); my(@FIELDS) = split(/$separator/, $fields); my(%FIELD); my($key, $value); foreach (@FIELDS) { ($key, $value) = split(/=/, $_); $value =~ s/&eq;/=/g; $value =~ s/=/=/g; $value =~ s/:/:/g; $value =~ s/'/!/g; $FIELD{$key} = $value; } %FIELD; } #======================================================================================= sub fcopy { my($src, $des, $permission) = @_; my($err); !-e "$src" && return('File Not Found'); !copy($src, $des) && return('Failure Copy'); if ($permission) { chmod(eval($permission), $des); } 0; } #======================================================================================= sub readini { my($filename, $norefresh) = @_; my($section, $key, $value, $err); if (open(INI,"$filename")) { my(@LIST) = ; close(INI); foreach (@LIST) { s/\n//g; s/\r//g; if ($_ ne '' && $_ !~ /^#/) { if (/^\[(.+)\]/) { $section = $1; if (!$norefresh) { undef %$section; undef @$section; } } else { if ($section) { if (/=/) { ($key, $value) = split(/=/, $_); 1 while $key =~ s/^ //; 1 while $key =~ s/ $//; 1 while $value =~ s/^ //; 1 while $value =~ s/ $//; $$section{$key} = $value; } else { push(@$section, $_); } } } } } } else { $err = 'Not Read Initial setting File'; } } #======================================================================================= sub saveini { my($filename, $inittext) = @_; my(@LIST) = split(/\n/, $inittext); my($err); if (open(INI,">$filename")) { my($i) = 0; foreach (@LIST) { s/&eq;/=/g; s/<//g; if (/^\[.+\]/ && $i) { print INI "\n"; } if ($_) { print INI "$_\n"; } $i++; } close(INI); } else { $err = 'Not Open Initial setting File'; } } #======================================================================================= sub readparts { my($variable, $changestr, $jcode) = @_; !$variable && ($variable = 'QUERY'); undef @$variable; undef %$variable; my($QUERY_DATA, $boundary, @PAIRS, $name, $value, $filename, $contenttype, $content, $c); binmode(STDIN); if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $QUERY_DATA, $ENV{'CONTENT_LENGTH'}); } else { $QUERY_DATA = $ENV{'QUERY_STRING'}; } if ($ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/i) { if ($ENV{'REQUEST_METHOD'} ne "POST") { return(not FormData Method POST); } $QUERY_DATA =~ /^(.+)(\r|\n)/; $boundary = $1; $QUERY_DATA =~ s/Content\-Disposition:\sform\-data;\s//g; @PAIRS = split(/$boundary/, $QUERY_DATA); $c = $boundary; $c =~ s/\r//g; $c =~ s/\n//g; shift(@PAIRS); foreach (@PAIRS) { if (/name=\".*\";\sfilename=\".*\"\s*Content\-Type/i) { s/(name=\"(.*)\";\sfilename=\"(.*)\"\s*(Content\-Type:\s*(.*)\/(.*))\s*)//; $name = $2; $filename = $3; $contenttype = $4; $content = "name=\"$name\"; filename=\"$filename\" $contenttype"; s/^\n//; if ($contenttype =~ /text/) { s/\r\n$//; } if ($_) { s/\r\n$//; $$variable{$name} = $_; push (@$variable, $content); } } else { s/name="(.*)"\s*//; $name = $1; $value = $_; $value =~ s/$c\-\-//; $value =~ s/\r$//g; $name = &encoding($name, $changestr, $jcode); $value = &encoding($value, $changestr, $jcode); if ($$variable{$name} ne '') { $$variable{$name} .= "\0$value"; foreach $line (@$variable) { if ($line =~ /name=\"$name\";/) { $line =~ s/value=\".*\"$/value=\"$$variable{$name}\"/; last; } } } else { $$variable{$name} = $value; $content = "name=\"$name\"; value=\"$value\""; push (@$variable, $content); } } } } else { @PAIRS = split(/&/,$QUERY_DATA); foreach (@PAIRS) { ($name, $value) = split(/=/, $_); $name = &encoding($name, $changestr, $jcode); $value = &encoding($value, $changestr, $jcode); if ($$variable{$name} ne '') { $$variable{$name} .= "\0$value"; foreach $line (@$variable) { if (index($line, "name=\"$name\";") >= 0) { # if ($line =~ /name=\"$name\";/) { $line =~ s/value=\".*\"$/value=\"$$variable{$name}\"/; last; } } } else { $$variable{$name} = $value; $content = "name=\"$name\"; value=\"$value\""; push (@$variable, $content); } } } 0; } #======================================================================================= sub encoding { local($_, $changestr, $encode) = @_; tr/+/ /; s/%([a-fA-F0-9]{2})/pack("c", hex($1))/eg; 1 while s/\r$//g; 1 while s/\s$//; s/\n//g; s/\t/  /g; if ($changestr) { $changestr =~ // && (s/>/>/g); $changestr =~ /=/ && (s/=/=/g); $changestr =~ /\"/ && (s/\"/"/g); $changestr =~ /\!/ && (s/\"/'/g); $changestr =~ /\:/ && (s/\:/:/g); } if ($encode) { &jcode'convert(*_, $encode); } $_; } #======================================================================================= sub changecsv { my($src, $des, $keys) = @_; my(@FIELDS, $key, $value, $line, $i, $keycount, $err); @KEYS = split(/\,/, $keys); $keycount = @KEYS - 1; if (open(SRC, "$src")) { if (open(DES, ">$des")) { while () { if ($keys) { $line = ''; $i = 0; @FIELDS = split(/\,/, $_); foreach $field (@FIELDS) { $fields =~ s/\n//g; $fields =~ s/=/&eq;/g; $fields =~ s//>/g; if ($i > $keycount) { last; } if (!$line) { $line = "$KEYS[$i]=$field"; } else { $line .= "\t$KEYS[$i]=$field"; } $i++; } $line .= "\t\n"; print DES $line; } else { $line = ''; @FIELDS = split(/\t/, $_); foreach $field (@FIELDS) { ($key, $value) = split(/=/, $field); $value =~ s/\r//g; $value =~ s/\n//g; $value =~ s/&eq;/=/g; $value =~ s/<//g; if (!$line) { $line = $value; } else { $line .= ",$value"; } } $line .= "\n"; print DES $line; } } close(DES); } else { $err = "Not Writing $des";; } close(SRC); } else { $err = "$src Not Found"; } $err; } #======================================================================================= sub hexstr { my($string, $flag) = @_; my($len, $i, $hexstr); $len = length($string); if ($flag) { for ($i = 0; $i < $len; $i++) { $hexstr .= unpack("H2", substr($string, $i, 1)); } $hexstr; } else { $string =~ s/([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $string; } } #======================================================================================= sub ichr { #------------------------------------ # Installation i-Mode Image Directory # my($dir) = '/usr/lib/imode/'; #------------------------------------ local($_) = &hexstr($_[0], 1); my($flag) = $_[1]; my($i, $code, $img); if ($flag == 2) { $img = '(^!^)'; } else { $img = ''; } for ($i = 63647; $i <= 63920; $i++) { $code = sprintf("%04X", $i); if ($flag == 1) { $img = &hexstr("", 1); } s/$code/$img/ig; } $_ = &hexstr($_, 0); $_; } #======================================================================================= sub graph { my($type, $border, $maxsize, $width, @GRAPH) = @_; my(@TITLE, @DATA, %DATA); my($title, $data, $max, $sum, $count, $color, $code, $size, $intro, $i, $j, $option); ($type, $option) = split(/:/, $type); if ($type == 2) { $intro = shift(@GRAPH); } my($colorspan) = 54321; if ($option) { foreach (@GRAPH) { ($title, $data) = split(/=/, $_); $i = sprintf("%04d", $data); $_ = "$i=$title=$data"; } @GRAPH = sort(@GRAPH); if ($option == 2) { @GRAPH = reverse(@GRAPH); } } $i = 0; foreach (@GRAPH) { if ($option) { ($dummy, $title, $data) = split(/=/, $_); } else { ($title, $data) = split(/=/, $_); } if ($title) { push(@TITLE, $title); $count++; if ($type == 2) { @DATA = split(/\,/, $data); $j = 0; foreach $line (@DATA) { $DATA{$i, $j} = $line; $DATA{$i} += $line; $j++; } $sum += $DATA{$i}; $i++; } else { push(@DATA, $data + 0); $max < $data && ($max = $data); $sum += $data; } } } !$sum && return(0); if ($type == 2) { undef @DATA; my(@INTRO) = split(/\,/, $intro); my($end) = $j - 1; for ($j = 0; $j <= $end; $j++) { for ($i = 0; $i < $count; $i++) { if ($DATA[$j] < $DATA{$i, $j}) { $DATA[$j] = $DATA{$i, $j}; } } } print "\n"; foreach $i (0 .. @TITLE -1) { print "\n"; } print "\n"; print "\n"; foreach (0 .. @TITLE -1) { print "\n"; } print "
\n"; print "
\n"; print "\n"; foreach (@INTRO) { $color += $colorspan; $code = sprintf("%06X", $color); print "\n"; } print "
$_
\n"; print "
\n"; print "
\n"; print "\n"; $color = 0; foreach $j (0 .. $end) { $color += $colorspan; $size = int($DATA{$i, $j} / $DATA[$j] * $maxsize + 0.5); if ($size) { $code = sprintf("%06X", $color); print "\n"; } } print "
"; $fontcolor = sprintf("%06X",hex("FFFFFF") - $color); print "$DATA{$i, $j}
 $TITLE[$_]
($DATA{$_})
\n"; } elsif ($type == 1) { print "\n"; foreach (0 .. @TITLE -1) { $rate = int($DATA[$_] / $sum * 1000 + 0.5) / 10; $size = int($DATA[$_] / $max * $maxsize); $color += $colorspan; $code = sprintf("%06X", $color); print "\n"; } print "\n"; foreach (0 .. @TITLE -1) { print "\n"; } print "
\n"; print "\n"; $fontcolor = sprintf("%06X",hex("FFFFFF") - $color); print "\n"; print "
$rate%
$TITLE[$_]
(", &comma($DATA[$_]), ")
\n"; } else { print "\n"; foreach (0 .. @TITLE -1) { $rate = int($DATA[$_] / $sum * 1000 + 0.5) / 10; $size = int($DATA[$_] / $max * $maxsize); $color += $colorspan; $code = sprintf("%06X", $color); print "\n"; print "\n"; print "\n"; print "\n"; } print "
$TITLE[$_](", &comma($DATA[$_]), ")"; if ($DATA[$_]) { print "\n"; print "
$rate%
\n"; } print "
\n"; } } #======================================================================================= sub error_view { my($err) = @_; my($cgiurl) = "http://$ENV{'SERVER_NAME'}$ENV{'SCRIPT_NAME'}"; &html_head('#FFFFFF','#000000','#0000FF','#FF0000','#00FF00','',4,4,'Error'); print "

Error

\n"; print "$cgiurl
\n"; print "$err\n"; print "
\n"; print "\n"; exit; } #======================================================================================= sub get_url { local($url, $flag, $encode) = @_; my(%HTML, $hostname, $addr, $path, $name); my($SOCK_STREAM) = ($] > 5 ? SOCK_STREAM : 1); my($protocol) = (getprotobyname('tcp'))[2]; $url =~ s/^(http|ftp):\/\///; if ($url =~ /^([\w\.\-]+)(\/.*)$/) { $hostname = $1; $path = $2; if ($path !~ /\/$/ && $path !~ /\./) { $path .= '/'; } } else { $HTML{'Err'} = '404 URL Syntax Error'; return(%HTML); } $addr = (gethostbyname($hostname))[4]; if (!$addr) { $HTML{'Err'} = "404 Not Server Name:$hostname"; return(%HTML); } $name = pack("S n a4 x8", 2, 80, $addr); socket(SOCK, 2, $SOCK_STREAM, $protocol); if (connect(SOCK, $name)) { binmode(SOCK); select(SOCK); $| = 1; select(STDOUT); print SOCK "GET $path HTTP/1.0\n"; print SOCK "HOST: $hostname:$protocol\n"; print SOCK "\n"; while () { if ($_) { if ($encode) { &jcode'convert(*_, $encode); } s/\r\n/\n/g; if (/^HTTP\/([\d\.]+)\s(\d+)\s(.+)$/) { if ($2 != 200) { $HTML{'Err'} = "$2 $3"; last; } } elsif (/^([\w\-]+):\s(.*)$/) { $HTML{$1} = $2; $1 =~ /Content\-Type/i && $flag && last; } elsif (/(.*)<\/title>/i) { $HTML{'Title'} = $1; if ($HTML{'Title'} =~ /\d+\s\w+$/) { $HTML{'Err'} = $HTML{'Title'}; last; } $HTML{'Body'} .= $_; } else { $HTML{'Body'} .= $_; } } } close(SOCK); } else { $HTML{'Err'} = 'Server Conection Error'; } %HTML; } #======================================================================================= sub whois { my($domain) = @_; my(@DOMAIN, $domainname); if ($domain =~ /\.jp$/i) { @DOMAIN = `whois -h whois.nic.ad.jp \"$domain\"`; } elsif ($domain =~ /\.info$/i) { @DOMAIN = `whois -h whois.afilias.net $domain`; } elsif ($domain =~ /\.biz$/i) { @DOMAIN = `whois -h whois.neulevel.biz $domain`; } elsif ($domain =~ /\.org$/i) { @DOMAIN = `whois -h whois.pir.org $domain`; } else { @DOMAIN = `whois $domain`; } if (!grep(/Domain\sName[:\]]/i, @DOMAIN) && !grep(/Domain\sInformation:/i, @DOMAIN) || grep(/No\smatch/i, @DOMAIN)) { $domain = ''; } $domain; } #======================================================================================= sub change_url { my($string, $change, $url) = @_; my(@URL) = split(/$change=/i, $string); my($new); my($top) = shift(@URL); foreach (@URL) { if (!/^([\"\']|^)http:/ && !/([\"\']|^)htp:/) { s/^([\"\']|^)(.*)/$change=$1$url$2/; } else { $_ = "$change=$_"; } $new .= $_; } $top . $new; } #======================================================================================= sub left { my($str, $len) = @_; $str = kaconv($str); if (length($str) > $len) { $str = substr($str, 0, $len); my($chr) = substr($str, $len - 1, 1); my($code) = unpack("C", $chr); if ($code > 127) { chop($str); } } $str; } #======================================================================================= sub week { my($date) = @_; my($year, $month, $day) = split(/\//, $date); my(@DATE) = localtime(dateserial($date)); my($start) = $day - $DATE[6]; my(@WEEK, $i); my($days) = &calendar2($year, $month, 0, 0, 1); if ($start < 1) { $month--; if ($month < 1) { $month = 12; $year--; } $days = &calendar2($year, $month, 0, 0, 1); $start = $days + $start; } $i = $start; foreach (1 .. 7) { if ($i > $days) { $i = 1; $month++; if ($month > 12) { $month = 1; $year++; } } $date = sprintf("%04d/%02d/%02d", $year, $month, $i); push(@WEEK, $date); $i++; } @WEEK; } #======================================================================================= sub os { # # UNIX : SunOS / Unix # Linux : Linux # Windows : Windows # # my($os) = `uname -a`; # if (!$os) { $os = `ver`; } } #======================================================================================= sub rgb { my($color) = @_; $color =~ s/#//g; my(@RGB, $i, $j, $str); for ($i = 0; $i < 6; $i+=2) { $str = substr($color, $i, 2); $RGB[$j] = hex($str); $j++; } @RGB; } #======================================================================================= sub ksubstr { my($str, $st, $en) = @_; my($klen) = 0; my($len) = length($str); my($cn, $string, $i); my($ksubstring) = ''; for ($i = 0; $i < $len; $i++) { $string = substr($str, $i, 1); $cn = unpack("C", $string); if ($cn >= 129 && $cn <= 159 || $cn >= 224 && $cn <= 252) { $i++; $string .= substr($str, $i, 1); } if ($klen >= $st && $klen < $st + $en) { $ksubstring .= $string; } $klen++; } $ksubstring; } #======================================================================================= sub klength { my($str) = @_; my($klen) = 0; my($len) = length($str); my($cn, $i); for ($i = 0; $i < $len; $i++) { $cn = unpack("C", substr($str, $i, 1)); if ($cn >= 129 && $cn <= 159 || $cn >= 224 && $cn <= 252) { $i++; } $klen++; } $klen; } #======================================================================================= sub kindex { my($str, $find) = @_; my($kindex) = -1; my($index) = index($str, $find); if ($index == 0) { $kindex = 0; } elsif ($index > 0) { my($cn, $i); for ($i = 0; $i <= $index; $i++) { $cn = unpack("C", substr($str, $i, 1)); if ($cn >= 129 && $cn <= 159 || $cn >= 224 && $cn <= 252) { $i++; } $kindex++; } } $kindex; } #======================================================================================= sub kreplace { my($str, $old, $new) = @_; my($kindex, $strlen, $findlen); my($leftstr, $rightstr); my($oldlen) = klength($old); my($newlen) = klength($new); if ($str ne '' && $old ne '' && $new ne '') { if(kindex($str, $old) >= 0) { $strlen = klength($str); $kindex = kindex($str, $old); $leftstr = ksubstr($str, 0, $kindex); $rightstr = ksubstr($str, $kindex + $oldlen, $strlen - $kindex - $oldlen); $rightstr = kreplace($rightstr, $old, $new); $str = "$leftstr$new$rightstr"; } } $str; } #======================================================================================= sub weekday { my($date, $timelag, $flag) = @_; my($serial) = dateserial($date, $timelag); my(@DATE) = localtime($serial); $DATE[5] += 1900; $DATE[4]++; if ($flag) { $DATE[6] = ('日','月','火','水','木','金','土') [$DATE[6]]; } $DATE[6]; } #======================================================================================= sub deletedir { my($dir) = @_; my(@FILES); if (opendir(FIL, $dir)) { @FILES = readdir(FIL); close FIL; foreach $line (@FILES) { if ($line ne '.' && $line ne '..') { if (-d "$dir/$line") { deletedir("$dir/$line"); } else { unlink("$dir/$line"); } } } rmdir($dir); } } #======================================================================================= sub dump16 { my($src, $des) = @_; open(IN, "$src"); binmode IN; $a = <IN>; open(OUT, ">$des"); binmode OUT; $i = 1; seek(IN, 0, 0); while (!eof(IN)) { $byt = read(IN, $dat, 32); print OUT "\'"; for ($j=0; $j < $byt; $j++){ print OUT unpack("H2", substr($dat, $j, 1)); } print OUT "\'\n"; } close OUT; close IN; } #======================================================================================= @TRYROGO = ( '474946383961a9000b00800000999999ffffff21f90405140001002c00000000', 'a9000b000002e48c8fa9cbed095a7cb4da8bb3017ceac06de2887812d4915b97', '4a6c682e71fcada176d7e5117934cfc8e580328ce9b74bea88a00c92c5831e9b', 'ab5d4f24bdf94e8aed95796c81b490a830d512fba0b6095ae67647a9d4ed287d', '07da8b5d33694ff7d5f4a215f73797a722b8f83345377818e918f7a652d6a798', '093656493409f6d226ea158a99883524b79824a784f4b8e9a714083ba3b937a4', '594756326318f88b98ca5ac534c677596bbb39ccfa8b9beb58d78b92a6c606fb', '28bd3b5a5d88bc3c6b27958c8dcbd96a46a96e84bcc4057ff1fa4eff0088635a', 'efde35bfafffef001b8202003b' ); #======================================================================================= sub uupackage { my($src, $des) = @_; my($filename, $Variable, $encode); my(@FILELIST); !-e "$src" && return('Not Found'); if (-e "$des") { if (open(IN, "$des")) { while (<IN>) { if ($_ =~ /^\[(.+)\]$/) { $filename = $1; push(@FILELIST, $filename); $Variable = $filename; $Variable =~ s/\./-comma-/g; } else { push(@$Variable, $_); } } close IN; } } if (!grep(/^$src$/, @FILELIST)) { push(@FILELIST, $src); } open(OUT, ">$des"); binmode OUT; foreach $file (@FILELIST) { print OUT "[$file]\n"; if ($file eq $QUERY{'src'}) { $encode = &changeuuencode($src); print OUT $encode_data; } else { $Variable = $file; $Variable =~ s/\./-comma-/g; foreach (@$Variable) { print OUT $_; } } } close OUT; 0; } #======================================================================================= sub unuupackage { my($src, $dir, $dirmod) = @_; my($filename, $openflag); !$dirmod && ($dirmod = '0777'); if (!-d "$dir") { mkdir($dir, eval($dirmod)); } if (open(IN, "$src")) { while (<IN>) { if ($_ =~ /^\[(.+)\]$/) { $openflag && close OUT; $filename = "$dir/$1"; open(OUT, ">$filename"); binmode OUT; $openflag = 1; } else { print OUT unpack("u", $_); } } $openflag && close OUT; close IN; } 0; } #======================================================================================= sub getzip { my($key, $ambiguous, $df, $preid, $pre, $encode) = @_; !$encode && ($encode = 'sjis'); # my($url) = 'http://tryhp.dip.jp/zipdb/dbsrv.cgi'; my($url) = 'http://redhat9.dip.jp/zipdb/dbsrv.cgi'; $url .= "?key=$key&ambiguous=$ambiguous&df=$df&preid=$preid&pre=$pre"; my(%TEXT) = get_url($url, 0, $encode); if ($TEXT{'Err'}) { return; } my(@DATA) = split(/\n/, $TEXT{'Body'}); shift(@DATA); @DATA; } #======================================================================================= sub createid { my($flag) = @_; my($hex) = sprintf("%lX", time) . sprintf("%lX", $$); $flag && ($hex =~ s/([\w]{1})/pack("c", hex($1)+65)/eg); $hex = substr(reverse($hex), 0, 8); $hex; } #=====================================End of perl-lib.pl================================ 1;