perl-lib.pl

 #=======================================================================================
# perl-lib.pl Version06.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/</&lt;/g;
#    $value =~ s/>/&gt;/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;
require 'Jcode.pm';
#use Jcode;
#$CR = "/015/012";
$CR = "/n";
$base64_alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
                   'abcdefghijklmnopqrstuvwxyz'.
                   '0123456789+/';
$base64_pad = '=';
$uuencode_alphabet = q|`!"#$%&'()*+,-./0123456789:;<=>?|.
                      '@ABCDEFGHIJKLMNOPQRSTUVWXYZ[//]^_';
$uuencode_pad = '`';
$tr_uuencode = " ".$uuencode_alphabet;
$tr_uuencode =~ s/(/W)///$1/g;
$tr_base64 = "A".$base64_alphabet;
$tr_base64 =~ s/(/W)///$1/g;

sub html_head {
 my($bgcolor, $text, $link, $vlink, $alink, $background, $topmargin, $leftmargin, $title, $fontsize, $border, $encode) = @_;
 !$encode && ($encode = 'shift_jis');
 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 "
 <html><head>
 <title>$title</title>
 <meta http-equiv=/"Content-Language/" content=/"ja/">
 <meta http-equiv=/"Content-Type/" content=/"text/html; charset=$encode/">
 </head>
 <style TYPE=text/css>
  <!--
  A:link    { text-decoration:none; color:$link }
  A:visited {text-decoration:none; color:$vlink }
  A:active  { text-decoration:none; color:$vlink }
  A:hover   { text-decoration:none; color:$alink }
  body      { font-size: $fontsize; }
  td        { font-size: $fontsize; }";
  if ($border) {
   print "
   input { font-size: $inpfont; border: 1 solid #008080 }
   select { font-size: $inpfont; border: 1 solid #008080 }
   textarea { font-size: $inpfont; border: 1 solid #008080 }";
  }
  print "
  -->
 </style>
 <body topmargin=$topmargin leftmargin=$leftmargin bgcolor=$bgcolor text=$text link=$link vlink=$vlink background=$background>";
}
#=======================================================================================
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 "
 <html><head>
 <title>$title</title>
 <meta http-equiv=/"Content-Language/" content=/"ja/">
 <meta http-equiv=/"Content-Type/" content=/"text/html; charset=shift_jis/">
 </head>
 <body>";
}
#=======================================================================================
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 = <FIL>;
        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 (<TEXT>) { 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 (<FIL>) {
    $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 encode_base64 {
 my($str) = @_;
 my($encode) = base64($str);
 $encode =~ s//n//g;
 $encode =~ s/=//g;
 $encode;
}
#=======================================================================================
sub decode_base64 {
 local ($str) = shift;
 local ($decode, $tmp, $offset, $len) = ('','', 0, 0);
 eval qq{
  /$str =~ tr|$tr_base64||cd;
  /$str =~ tr|$tr_base64|$tr_uuencode|;
 };
 $len = length($str);
 while ($offset + 60 <= $len) {
  $tmp = substr($str, $offset, 60);
  $offset += 60;
  $decode .= unpack("u", "M" . $tmp);
 }
 if ($offset < $len) {
  $tmp = substr($str, $offset, $len - $offset);
  $decode .= unpack("u", substr($uuencode_alphabet, length($tmp) * 3 / 4, 1) . $tmp);
 }
 $decode;
}
#=======================================================================================
sub iso2022 {
 local($str) = @_;
 jcode'convert(*str, 'jis');
 $str= "=?iso-2022-jp?B?" . base64($str) . "?=";
 $str;
}
#=======================================================================================
sub subjectiso2022 {
 my($str, $encode) = @_;
 my($max) = klength($str,$encode);
 my($subject, $s);
 my($i) = 0;
 while ($i <= $max - 1) {
  $s = ksubstr($str, $i, 18, $encode);
  $i += klength($s, $encode);
  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 = <DB>;
  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;
 !$filename && ($filename = 'this_not_name_temporaryfile');
 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 (<IMG>);
    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/(.*)(&lt;(img([!-:A-~/s/=]+))&gt;)/$1<img$4>/i;
 1 while s/(.*)(&lt;(b)&gt;(.*)&lt;//b&gt;)/$1<b>$4<//b>/i;
 1 while s/(.*)(&lt;(u)&gt;(.*)&lt;//u&gt;)/$1<u>$4<//u>/i;
 1 while s/(.*)(&lt;(i)&gt;(.*)&lt;//i&gt;)/$1<i>$4<//i>/i;
 1 while s/(.*)(&lt;(p[/s/w/=/#/"/'/-/;/:/.]+)/&gt;(.*)/&lt;//p/&gt;)/$1<$3>$4<//p>/i;
 1 while s/(.*)(&lt;(font[/s/w/=/#/"/'/-/;/:/.]+)/&gt;(.*)/&lt;//font/&gt;)/$1<$3>$4<//font>/i;
 $_;
}
#=======================================================================================
sub htmlparser {
 local($_, $decode) = @_;
 s/&lt;/</g; s/&gt;/>/g; s/&eq;/=/g; s/&#61;/=/g;
 s/&/w+;/ /ig; s/&#/d+;//g; s/[/t/r/n]//g;
 my(@TAGS) = split(/</, $_);
 my(@STE, $str, $tagstr);
 $str = $TAGS[0];
 foreach (1 .. @TAGS - 1) {
  if ($TAGS[$_] =~ />/) {
   ($tagstr, @STR) = split(/>/, $TAGS[$_]);
   $str .= join('', @STR);
  } else {
   $str .= "$TAGS[$_]";
  }
 }
 $decode && (jcode'convert(*str, $decode));
 $str;
}
#=======================================================================================
sub tag_check {
 local($_, @FREETAGS) = @_;
 my(%SINGLETAGS) = ('input',1,'br',1,'hr',1,'img',1,'meta',1,'li',1);
 my(@TAGS, @REVTAGS, @OPENTAGS, @CLOSETAGS);
 local($tagname, $match, $word, $i, $string, $opentags, $closetags);
 s/&lt;/</g;
 s/&gt;/>/g; s/&eq;/=/g; s/&#61;/=/g;
 if (//</) {
  @TAGS = split(//</,$_);
  @REVTAGS = reverse(@TAGS);
  foreach (@REVTAGS) {
   if (/(//(/w+)/>)/i) {
    $tagname = $2;
    $tagname=~ tr/[A-Z]/[a-z]/;
    if (grep(/$tagname/, @FREETAGS)) { push(@CLOSETAGS, "</$tagname>"); }
   }
  }
  $string = $TAGS[0];
  foreach $l (1 .. @TAGS - 1) {
   $_ = $TAGS[$l];
   if (/>/) {
    $_ = "<$_";
    $match = 0;
    if (/<(/w+)/i) {
     $word = $1;
     $word =~ tr/[A-Z]/[a-z]/;
     push(@OPENTAGS,"<$word/>");
     if (grep(/^$word$/i, @FREETAGS)) {
      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+)([/w/:]*)>/i) {
      $word = $1;
      $word =~ tr/[A-Z]/[a-z]/;
      if (!grep(/^$word$/, @FREETAGS)) {
        s/<//$word([/w/:]*)>//i;
        $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; }
   !$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<a href=$2 $target>$string<//a>/g;
 } else {
  s/([^=^/"]|^)((http|ftp):[!#-9A-~?=]+)/$1<a href=$2 $target>$2<//a>/g;
 }
 s/([/w/-/_/.]+/@[/w/-/_/.]+)/<a href=mailto:$1>$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/</&lt;/g;
 s/>/&gt;/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) {
   $_ = 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) = @_;
 if ($timelag) {
  $timelag = $timelag * -3600;
 }
 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] + $timelag;
}
#=======================================================================================
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 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 scramble64 {
 my($str, $flg, $key) = @_;
 my(@st,$s, $len);
 my($noins) = 0;
 if ($flg) {
  if ($key) {
   $s = substr($key, 0, 2);
   $key = 0;
   foreach (0..1) {
    $key += unpack("C", substr($s, $_, 1));
   }
  } else {
   foreach (0 .. 1) {
    $st[$_] = int(rand(26)) + 97;
   }
   $s = pack("c2", $st[0], $st[1]);
   $key = $st[0] + $st[1];
  }
  $str = encode_base64($s . scramble($str, 1, $key, $key));
 } else {
  $str = decode_base64($str);
  $s = substr($str, 0, 2);
  $len = length($str);
  $str = substr($str, 2, $len - 2);
  foreach (0..1) {
   $key += unpack("C", substr($s, $_, 1));
  }
  $str = scramble($str, 0, $key, $key);
 }
 $str;
}
#=======================================================================================
sub setcrypt {
 #
 # 2桁のkeyをランダムに指定して暗号化
 # htpasswdのベーシック認証コンパチ
 #
 my($pw) = @_;
 my(@st, $s, $i);
 srand(time|$$);
 foreach (0 .. 1) {
  $st[$_] = int(rand(26)) + 97;
 }
 $s = pack("c2",$st[0],$st[1]);
 crypt($pw, $s);
}
#=======================================================================================
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, $encode) = @_;
 my($len) = klength($string, $encode);
 my($str) = '';
 for ($i=0;$i < $len;$i++) {
  $str .= kaconv2(ksubstr($string, $i, 1, $encode), $encode);
 }
 $str;
}
sub kaconv2 {
 my($string, $encode) = @_;
 my($i, $j, $unpack, $pack);
 my($length) = length($string);
 local($_);
 for($i = 0; $i < $length; $i++) {
  $j = substr($string, $i, 1);
  $_ .= "!". unpack("C", $j);
 }
 if ($encode =~ /euc/i) {
  my(@ASCII) = (
   '164-44', '165-46', '167-58', '168-59', '169-63', '170-33',
   '176-94', '178-95', '191-47', '195-124', '202-40', '203-41',
   '206-91', '207-93', '208-123', '209-125', '210-60', '211-62', '220-43',
   '221-45', '225-61', '227-60', '228-62', '236-39', '237-34', '239-92',
   '240-36', '243-37', '244-35', '245-38', '246-42', '247-64'
  );
  foreach $ascii (@ASCII) {
   ($unpack, $pack) = split(//-/, $ascii);
   s/!161!$unpack/!$pack/g;
  }
  if (/!163!(/d+)/) {
   $st = $1 - 128;
   $_ =~ s/!163!(/d+)/!$st/;
  }
 } else {
  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/&#61;/=/g;
  $value =~ s/&colon;/:/g;
  $value =~ s/&apos;/!/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) = <INI>;
  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/ $//; $key =~ s/&#61;/=/g;
       1 while $value =~ s/^ //; 1 while $value =~ s/ $//; $value =~ s/&#61;/=/g;
       $$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/&lt;/</g; s/&gt;/>/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($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/&nbsp;&nbsp;/g;
 if ($changestr) {
  $changestr =~ /</ && (s/</&lt;/g);
  $changestr =~ />/ && (s/>/&gt;/g);
  $changestr =~ /=/ && (s/=/&#61;/g);
  $changestr =~ //"/ && (s//"/&quot;/g);
  $changestr =~ //!/ && (s//"/&apos;/g);
  $changestr =~ //:/ && (s//:/&colon;/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 (<SRC>) {
    if ($keys) {
     $line = ''; $i = 0;
     @FIELDS = split(//,/, $_);
     foreach $field (@FIELDS) {
      $fields =~ s//n//g;
      $fields =~ s/=/&eq;/g;
      $fields =~ s/</&lt;/g;
      $fields =~ s/>/&gt;/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/&lt;/</g;
      $value =~ s/&gt;/>/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("<img src=$dir$code.gif>", 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 "<table border=$border cellspacing=0><tr><td>/n";
   print "<table border=0 cellpadding=0><tr><td bgcolor=#000000>/n";
    print "<table border=0 cellspacing=1 cellpadding=2>/n";
     foreach (@INTRO) {
      $color += $colorspan;
      $code = sprintf("%06X", $color);
      print "<tr><td width=16 bgcolor=#$code></td><td bgcolor=#FFFFFF><font size=2>$_</font></td></tr>/n";
     }
    print "</table>/n";
   print "</td></tr></table>/n";
   print "</td>/n";
   foreach $i (0 .. @TITLE -1) {
    print "<td align=center valign=bottom>/n";
    print "<table border=1 cellspacing=0 cellpadding=0 width=$width bordercolorlight=#EEEEEE bordercolordark=#333333>/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 "<tr><td height=$size bgcolor=#$code align=center valign=top bordercolorlight=#$code bordercolordark=#EEEEEE>";
      $fontcolor = sprintf("%06X",hex("FFFFFF") - $color);
      print "<font size=2 color=#$fontcolor>$DATA{$i, $j}</font></td></tr>/n";
     }
    }
    print "</table></td>/n";
   }
   print "</tr><tr>/n";
   print "<td>　</td>/n";
   foreach (0 .. @TITLE -1) {
    print "<td align=center><font size=2>$TITLE[$_]<br>($DATA{$_})</font></td>/n";
   }
  print "</tr></table>/n";
  
 } elsif ($type == 1) {
  print "<table border=$border cellspacing=0><tr>/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 "<td align=center valign=bottom>/n";
    print "<table border=1 cellspacing=0 cellpadding=0 width=$width height=$size bordercolorlight=#EEEEEE bordercolordark=#333333><tr>/n";
    $fontcolor = sprintf("%06X",hex("FFFFFF") - $color);
    print "<td bgcolor=#$code align=center valign=top bordercolorlight=#$code bordercolordark=#$code><font size=2 color=#$fontcolor>$rate%</font></td>/n";
    print "</tr></table></td>/n";
   }
   print "</tr><tr>/n";
   foreach (0 .. @TITLE -1) {
    print "<td align=center><font size=2>$TITLE[$_]<br>(", &comma($DATA[$_]), ")</font></td>/n";
   }
  print "</tr></table>/n";
 } else {
  print "<table border=$border cellspacing=0>/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 "<tr>/n";
     print "<td align=center><font size=2>$TITLE[$_](", &comma($DATA[$_]), ")</font></td>/n";
     print "<td>";
     if ($DATA[$_]) {
      print "<table border=1 cellspacing=0 cellpadding=0 width=$size bordercolorlight=#$code bordercolordark=#333333><tr>/n";
      print "<td align=right bgcolor=$code bordercolorlight=#$code bordercolordark=#$code><font size=2 color=#000000>$rate%</font></td></tr></table>/n";
     }
     print "</td>/n";
    print "</tr>/n";
   }
  print "</table>/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 "<p><font size=5><b>Error</b></font></p>/n";
 print "$cgiurl<br>/n";
 print "$err/n";
 print "<hr>/n";
 print "</body></html>/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/r/n/r/n";
  while (<SOCK>) {
   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>(.*)<//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) {
  # .jp    .co.jp  .ne.jp
  # .ac.jp .or.jp  .gr.jp
  # .ad.jp
  @DOMAIN = `whois -h whois.jp /"$domain/"`;
 } elsif ($domain =~ //.edu$/i) {
  # .edu
  @DOMAIN = `whois -h whois.educause.net $domain`;
 } elsif ($domain =~ //.tv$/i) {
  # .tv
  @DOMAIN = `whois -h whois.www.tv $domain`;
 } elsif ($domain =~ //.info$/i) {
  # .info
  @DOMAIN = `whois -h whois.afilias.net $domain`;
 } elsif ($domain =~ //.biz$/i) {
  # .biz
  @DOMAIN = `whois -h whois.neulevel.biz $domain`;
 } elsif ($domain =~ //.to$/i) {
  # .to
  @DOMAIN = `whois -h whois.tonic.to $domain`;
 } elsif ($domain =~ //.org$/i) {
  # .org
  @DOMAIN = `whois -h whois.pir.org $domain`;
 } elsif ($domain =~ //.cn$/i) {
  # .cn
  @DOMAIN = `whois -h whois.cnnic.net.cn $domain`;
 } elsif ($domain =~ //.us$/i) {
  # .us
  @DOMAIN = `whois -h whois.nic.us $domain`;
 } elsif ($domain =~ //.ws$/i) {
  # .ws
  @DOMAIN = `whois -h whois.worldsite.ws $domain`;
 } elsif ($domain =~ //.in$/i) {
  # .in
  @DOMAIN = `whois -h whois.ncst.ernet.in $domain`;
 } elsif ($domain =~ //.bz$/i) {
  # .bz
  @DOMAIN = `whois -h whois.belizenic.bz $domain`;
 } elsif ($domain =~ //.uk$/i) {
  # .uk
  @DOMAIN = `whois -h whois.nic.uk $domain`;
 } else {
  # .com  .net
  # .cc   .tv   .ac
  @DOMAIN = `whois $domain`;
 }
 if ((!grep(/Domain/sName[:/]/./n]/i, @DOMAIN)
  && !grep(/Domain/sDetails]/i, @DOMAIN)
  && !grep(/Domain/sInformation:/i, @DOMAIN))
  || grep(/No/s*match/i, @DOMAIN)
  || grep(/Not/s*found/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, $encode) = @_;
 $str = kaconv($str, $encode);
 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, $encode) = @_;
 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 ($encode =~ /euc/i) {
   if ($cn >= 161) {
    $i++;
    $string .= substr($str, $i, 1);
   }
  } else {
   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, $encode) = @_;
 my($klen) = 0;
 my($len) = length($str);
 my($cn, $i);
 for ($i = 0; $i < $len; $i++) {
  $cn = unpack("C", substr($str, $i, 1));
  if ($encode =~ /euc/i) {
   if ($cn >= 161) { $i++; }
  } else {
   if ($cn >= 129 && $cn <= 159 || $cn >= 224 && $cn <= 252) { $i++; }
  }
  $klen++;
 }
 $klen;
}
#=======================================================================================
sub kindex {
 my($str, $find, $encode) = @_;
 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 ($encode =~ /euc/i) {
    if ($cn >= 161) { $i++; }
   } else {
    if ($cn >= 129 && $cn <= 159 || $cn >= 224 && $cn <= 252) { $i++; }
   }
   $kindex++;
  }
 }
 $kindex;
}
#=======================================================================================
sub kreplace {
 my($str, $old, $new, $encode) = @_;
 my($kindex, $strlen, $findlen);
 my($leftstr, $rightstr);
 my($oldlen) = klength($old, $encode);
 my($newlen) = klength($new, $encode);
 if ($str ne '' && $old ne '' && $new ne '') {
  if(kindex($str, $old, $encode) >= 0) {
   $strlen = klength($str, $encode);
   $kindex = kindex($str, $old, $encode);
   $leftstr = ksubstr($str, 0, $kindex, $encode);
   $rightstr = ksubstr($str, $kindex + $oldlen, $strlen - $kindex - $oldlen, $encode);
   $rightstr = kreplace($rightstr, $old, $new, $encode);
   $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 createserialid {
 my($fid) = substr(sprintf("%09d", $$), 5, 4);
 time . $fid;
}
#=======================================================================================
sub createid {
 my($flag) = @_;
 my($hex1) = sprintf("%lX", time);
 my($process) = sprintf("%02d", reverse(substr(reverse($$), 0, 2)));
 my($hex2) = sprintf("%lX", $process);
 length($hex2) == 1 && ($hex2 = "0$hex2");
 my($hex) = "$hex1$hex2";
 while (length($hex) < 10) { $hex .= '0'; }
 $flag && ($hex =~ s/([/w]{1})/pack("c", hex($1)+65)/eg);
 $hex;
}
#=======================================================================================
sub getfullpath {
 my(@LOCAL) = split(////, $_[0]);
 my(@PATH) = split(////, $0);
 my($i) = 2; my($local) = '';
 foreach (@LOCAL) {
  if ($_ eq '..') {
   $i++;
  } else {
   if ($local) { $local .= "/$_"; } else { $local = $_; }
  }
 }
 my($path) = '';
 foreach (0 .. @PATH-$i) {
  $path .= "$PATH[$_]/";
 }
 $path .= "$local";
}
#=====================================End of perl-lib.pl================================
1;