"もOK)か判定する
sub CheckEMailAddress
{
my $email = @_;
my $esc = '\\\\';
my $Period = '\.';
my $space = '\040';
my $tab = '\t';
my $OpenBR = '\[';
my $CloseBR = '\]';
my $OpenParen = '\(';
my $CloseParen = '\)';
my $NonASCII = '\x80-\xff';
my $ctrl = '\000-\037';
my $CRlist = '\n\015';
my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
my $quoted_pair = qq<${esc}[^$NonASCII]>;
my $ctext = qq<[^$esc$NonASCII$CRlist()]>;
my $Cnested = qq<$OpenParen$ctext*(?:$quoted_pair$ctext*)*$CloseParen>;
my $comment =
qq<$OpenParen$ctext*(?:(?:$quoted_pair|$Cnested)$ctext*)*$CloseParen>;
my $X = qq<[$space$tab]*(?:${comment}[$space$tab]*)*>;
my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
my $atom = qq<$atom_char+(?!$atom_char)>;
my $quoted_str = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">;
my $word = qq<(?:$atom|$quoted_str)>;
my $domain_ref = $atom;
my $domain_lit = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>;
my $sub_domain = qq<(?:$domain_ref|$domain_lit)$X>;
my $domain = qq<$sub_domain(?:$Period$X$sub_domain)*>;
my $route = qq<\@$X$domain(?:,$X\@$X$domain)*:$X>;
my $local_part = qq<$word$X(?:$Period$X$word$X)*>;
my $addr_spec = qq<$local_part\@$X$domain>;
my $route_addr = qq[<$X(?:$route)?$addr_spec>];
my $phrase_ctrl = '\000-\010\012-\037';
my $phrase_char =
qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
my $phrase =
qq<$word$phrase_char*(?:(?:$comment|$quoted_str)$phrase_char*)*>;
my $mailbox = qq<$X(?:$addr_spec|$phrase$route_addr)>;
return 1 if $email =~ /^$mailbox$/o;
return 0;
}
# メールアドレス(addr-spec)のみの正規表現 $mail_regex
sub CheckEMailAddrSpec
{
my $email = @_;
my $esc = '\\\\';
my $Period = '\.';
my $space = '\040';
my $OpenBR = '\[';
my $CloseBR = '\]';
my $NonASCII = '\x80-\xff';
my $ctrl = '\000-\037';
my $CRlist = '\n\015';
my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
my $quoted_pair = qq<${esc}[^$NonASCII]>;
my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
my $atom = qq<$atom_char+(?!$atom_char)>;
my $quoted_str = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">;
my $word = qq<(?:$atom|$quoted_str)>;
my $domain_ref = $atom;
my $domain_lit = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>;
my $sub_domain = qq<(?:$domain_ref|$domain_lit)>;
my $domain = qq<$sub_domain(?:$Period$sub_domain)*>;
my $local_part = qq<$word(?:$Period$word)*>;
my $addr_spec = qq<$local_part\@$domain>;
my $mail_regex = $addr_spec;
return 1 if($email =~ /^$mail_regex$/o);
return 0;
}
#===============================================
# 暗号化関係
#===============================================
my $salt = ".b";
sub crypt
{
my ($str) = @_;
my $ostr = crypt($str,$salt);
$ostr =~ s/[&+?=]/@/g;
return $ostr;
}
sub IsAllowedIPAddress
{
my ($IPAddress, @allowed) = @_;
foreach my $exp (@allowed) {
return 1 if($IPAddress =~ /$exp/i);
}
return 0;
}
#==========================================
# require "mycgi.pl";
# print &mycgi'InitHTML('Welcome to our HP');
#==========================================
sub PrintHTMLHeader
{
my($CharSet) = (@_);
if($CharSet eq '') {
$CharSet = 'x-sjis';
}
print "Content-type: text/html; charset=$CharSet\n\n";
}
sub InitHTML
{
my($WebTitle, $CharSet, $LinkTarget) = (@_);
if($WebTitle eq ''){
$WebTitle = "No title";
}
if($CharSet eq '') {
$CharSet = 'x-sjis';
}
if($LinkTarget eq '') {
$LinkTarget = '_blank';
}
&PrintHTMLHeader($CharSet);
print "\n";
print "\n";
print "\n";
print " \n";
print " $WebTitle\n";
print " \n";
print "\n";
print "\n";
}
sub EndHTML
{
print "\n";
print "\n";
}
sub GetHTMLParagraph
{
my ($str) = (@_);
$str =~ /^([\w\W\n]*?)()([\w\W]*)$/mi;
my $line = $1;
my $paragraph = $2;
my $len = length($line) + length($paragraph);
my $content = substr($str, $len);
# print "strlen: " . length($str) . " " . $len . " " . length($content) . "\n";
# print "str1: ". substr($str, 0, 200) . "\n";
# print "line1: $line\n";
# print "para1: $paragraph\n";
# my $cont1 = substr($content, 0, 200);
# print "cont1: $cont1\n";
return ($line, $paragraph, $content);
}
sub DequoteXML
{
my ($str,$DoDecode) = (@_);
$str =~ s/<[\w\W]*?>//gmi;
$str =~ s/\n//gm;
if($DoDecode) {
$str =~ s/"/\"/gmi;
# $str =~ s/</\/gmi;
$str =~ s/&nbps;/ /gmi;
}
return $_[0] = $str;
}
sub GetIPAddress
{
my($ip) = (@_);
$ip = $ENV{'REMOTE_ADDR'};
return $ip;
}
sub IsJapanese
{
my($str) = (@_);
Jcode::convert(\$str, 'euc');
if($str =~ /[\x8E\xA1-\xFE]/) {
return 1;
}
return 0;
}
#==========================================
# Decode / Encode
#==========================================
sub MySQLQuote
{
my($str,$mysqlcharcode) = (@_);
#print "s: $str
\n";
Jcode::convert(\$str, $mysqlcharcode) if($mysqlcharcode ne '');
$str =~ s/\\/\\\\/g; # \
## $str =~ s/\c[/\\\c[/g; # ESC
# $str =~ s/\//\\\//g; # \
$str =~ s/\"/\\\"/g;
# $str =~ s/\'/\\\'/g;
# $str =~ s/\:/\\\:/g;
# $str =~ s/\(/\\\(/g;
# $str =~ s/\)/\\\)/g;
## $str =~ s/\[([^\c[])/\\\[\1/g;
# $str =~ s/\[/\\\[/g;
## $str =~ s/\]/\\\]/g;
#print "s: $str
\n";
return $str;
}
sub URLEncode
{
my ($s) = (@_);
$s =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$s =~ tr/ /+/;
return $s;
}
sub URLDecode
{
my ($s2) = (@_);
#print "s0: $s2
\n";
$s2 =~ tr/+/ /;
$s2 =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
#print "s1: $s2
\n";
return $s2;
}
#16進コード
sub StrToHex
{
my ($s) = @_;
$s =~ s/(.)/'\\x' . uc unpack('H2', $1)/eg;
return $s;
}
sub RecoverHTMLChar
{
my ($s, $charset) = @_;
$s =~ s/&#([0-9]+);/pack('I', $1)/eg;
Jcode::convert(\$s, $charset) if($charset ne '');
return $s;
}
sub StringToHex
{
my ($s) = @_;
$s = '='.unpack("H2",$s);
tr/a-f/A-F/;
return $s;
}
sub QPEncode
{
my ($string) = (@_);
$string =~ s/=/=3D/g;
$string =~ s/\t$/=09/;
$string =~ s/ $/=20/;
$string =~ s/([^!-" \t])/&StringToHex($1)/eg;
return $string;
}
sub QPDecode
{
my ($string) = (@_);
$string =~ s/=\r\n//g;
$string =~ s/=\n//g;
$string =~ s/=\r//g;
$string =~ s/=([0-9a-z]{2})/pack("C",hex($1))/gei;
return $string;
}
my $Base64Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
'abcdefghijklmnopqrstuvwxyz'.
'0123456789+/'; # and '='
my $Base64Pad = '=';
# b64decodesub -- takes some characters in the base64 alphabet and
# returns the raw bytes that they represent.
sub Base64DecodeSub
{
local ($_) = @_[0];
# translate each char to a value in the range 0 to 63
eval qq{ tr!$Base64Alphabet!\0-\77!; };
# keep 6 bits out of every 8, and pack them together
$_ = unpack('B*', $_); # look at the bits
s/(..)(......)/$2/g; # keep 6 bits of every 8
s/((........)*)(.*)/$1/; # throw away spare bits (not multiple of 8)
$_ = pack('B*', $_); # turn the bits back into bytes
$_; # return
}
sub Base64Decode2
{
my ($str) = (@_);
my $leftover = '';
# ignore illegal characters
$str =~ s/[^$Base64Alphabet]//go;
# insert the leftover stuff from last time
$str = $leftover . $str;
# if there are not a multiple of 4 bytes, keep the leftovers for later
$str =~ m/^((....)*)/;
$str = $&;
$leftover = $';
# turn each group of 4 values into 3 bytes
$str =~ s/(....)/&Base64DecodeSub($1)/eg;
# special processing at EOF for last few bytes
if (eof)
{
$str .= &Base64DecodeSub($leftover);
$leftover = '';
}
# output it
return $str;
}
sub Base64Decode
{
return decode_base64($_[0]);
}
sub Base64Encode
{
return encode_base64($_[0]);
}
#==========================================
# Directory
#==========================================
my $DirectorySeparator = "\\";
sub CopyFile
{
my ($infile, $outfile) = (@_);
open(IN, "<$infile") or return -1;
open(OUT, ">$outfile") or return -2;
my @content = ;
print OUT @content;
close(OUT);
close(IN);
}
sub DelSpace
{
my ($s) = @_;
$s =~ s/^\s*//;
$s =~ s/\s*$//;
return $_[0] = $s;
}
sub DelQuote
{
my ($s) = @_;
chomp($s);
$s =~ s/^\s*//;
$s =~ /^(.)(.*)(.)$/;
my $firstchar = $1;
my $restchar = $2;
my $lastchar = $3;
if($firstchar eq '"' and $lastchar eq '"') {
return $restchar
}
return $restchar
if($firstchar eq '\'' and $lastchar eq '\'');
return $_[0];
}
#==========================================
# require "mycgi.pl";
#
# &mycgi'PrintWithReplaced($infile, $outfile, "{EMail}", $a, "{Code}", $b);
# ex. $infile = '-', 'a.in', $outfile="> a.out", ">> a.append", ">-"
#==========================================
sub PrintWithReplaced
{
my $narg = @_;
my @a = @_;
my $infile = $a[0];
my $outfile = $a[1];
my($org,$target);
#print "narg: $narg : infile: $infile
\n";
open(INFILE, $infile) or die "$infile: $!";
open(OUTFILE, $outfile) or die "$outfile: $!";
my($line);
while(defined($line = )){
for(my $i = 2 ; $i < $narg ; $i += 2){
if($Debug) {
print "change($i):
\n";
# [" . $a[$i] . "] to [" . $a[$i+1] . "]
\n";
}
$line =~ s/$a[$i]/$a[$i+1]/g;
}
print OUTFILE $line;
}
close(INFILE);
close(OUTFILE);
}
#==========================================
# require "mycgi.pl";
#
# &mycgi'PrintStringWithReplaced($str, $outfile, "{EMail}", $a, "{Code}", $b);
# ex. $infile = '-', 'a.in', $outfile="> a.out", ">> a.append", ">-"
#==========================================
sub PrintStringWithReplaced
{
my $narg = @_;
my @a = @_;
my $str = $a[0];
my $outfile = $a[1];
my($org,$target);
open(OUTFILE, $outfile) or die "$outfile: $!";
for(my $i = 2 ; $i < $narg ; $i += 2){
$str =~ s/$a[$i]/$a[$i+1]/g;
}
print OUTFILE $str;
close(OUTFILE);
}
#==========================================
# &mycgi'ConvertString($str, "{EMail}", $a, "{Code}", $b);
#==========================================
sub ConvertString
{
my $narg = @_;
my @a = @_;
my $str = $a[0];
for(my $i = 1 ; $i < $narg ; $i += 2){
$str =~ s/$a[$i]/$a[$i+1]/g;
}
return $_[0] = $str;
}
sub IsValidPassword
{
my ($password) = (@_);
if($password =~ /^[a-zA-Z0-9_]+$/){
return 1;
}
return 0;
}
sub IsValidEMailAddress
{
my ($email) = (@_);
if($email =~ /^[a-zA-Z0-9._\-+\%\$#!&~]+@[a-zA-Z0-9._\-+]+$/){
return 1;
}
return 0;
}
sub BuildDateString
{
my ($time) = (@_);
my ($sec, $min, $hour, $mday, $mon, $year,
$wday, $yday, $isdst) = localtime($time);
$year += 1900;
$mon++;
my $str = sprintf("%02d/%02d/%02d %02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
return $str;
}
sub GetFileSize
{
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($_[0]);
return $size;
}
sub GetWriteDate
{
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($_[0]);
return $mtime;
}
#==========================================
# DB subroutines
#==========================================
sub OpenDB
{
my ($DBServer, $DBUser, $DBPassword, $DBName) = @_;
my $db;
my $sth;
$db = DBI->connect('DBI:mysql:'.$DBName.':'.$DBServer, $DBUser, $DBPassword);
if(!$db){
print "Unable to connect to $DBName
\n";
return 0;
}
$sth = $db->prepare("use $DBName;\n");
my $result = $sth->execute;
if(!$result){
print "use: SQL execution error
\n";
return 0;
}
#print "db:$db $sth
\n";
return ($db,$sth);
}
sub CloseDB
{
my ($db, $sth) = @_;
$sth->finish;
$db->disconnect;
}
sub DBExecute
{
my ($db, $sth, $command) = @_;
$sth = $db->prepare($command);
my $ret = $sth->execute;
return ($sth,$ret);
}
#===============================================
# HTML / Cookie関係
#===============================================
my %COOKIE;
my $CGIFiles = "(\.cgi|\.pl|\.php)[^/]*\$";
my @IndexFiles = ("index.html", "index.htm", "Index.html", "Index.htm",
"Default.htm", "Default.html", "default.htm", "default.html");
#
# Cookieの値を読み出す
#
sub getCookie {
my($xx, $name, $value);
foreach my $xx (split(/; */, $ENV{'HTTP_COOKIE'})) {
($name, $value) = split(/=/, $xx);
$value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/eg;
$COOKIE{$name} = $value;
}
}
#
# Cookieに値を書き込むためのSet-Cookie:ヘッダを生成する
#
sub setCookie {
my($tmp, $val);
$val = $_[1];
$val =~ s/(\W)/sprintf("%%%02X", unpack("C", $1))/eg;
$tmp = "Set-Cookie: ";
$tmp .= "$_[0]=$val; ";
$tmp .= "expires=Tue, 1-Jan-2030 00:00:00 GMT;";
return($tmp);
}
#
# Cookieを削除するためのSet-Cookie:ヘッダを生成する
#
sub clearCookie {
my $tmp = "Set-Cookie: ";
$tmp .= "$_[0]=xx; ";
$tmp .= " expires=Tue, 1-Jan-1980 00:00:00 GMT;";
return($tmp);
}
sub ConvertHTMLToFullURL
{
my ($Content, $SourceURL, $Debug) = (@_);
my $res;
my $ConvContent;
$res = $Content;
$ConvContent = "";
while(1) {
my $count =
($res =~ /^(.*?)(\)(.*?)(\<\/a.*?\>)(.*)$/si);
if($count == 0) {
$ConvContent .= $res;
last;
}
my $header = $1;
my $tag1 = $2;
my $linkurl = $3;
my $tag2 = $4;
my $linkstr = $5;
my $tag3 = $6;
$res = $7;
if($Debug) {
print " URL: $linkurl\n";
}
my $convurl = &ConvertURLtoFullURL($linkurl, $SourceURL);
if($Debug) {
print "ConvURL: $convurl\n";
}
$ConvContent .= "$1$2$convurl$4$5$6";
}
$res = $ConvContent;
$ConvContent = "";
while(1) {
my $count =
($res =~ /^(.*?(background|image|src)\s*=\s*\")(.*?)(\".*)$/si);
if($count == 0) {
$ConvContent .= $res;
last;
}
my $header = $1;
my $linkurl = $3;
$res = $4;
if($Debug) {
print " URL: $linkurl\n";
}
my $convurl = &ConvertURLtoFullURL($linkurl, $SourceURL);
if($Debug) {
print "ConvURL: $convurl\n";
}
$ConvContent .= "$1$convurl";
}
return $_[0] = $ConvContent;;
}
sub ConvertURLtoFullURL
{
my ($linkurl, $url) = (@_);
my $convurl;
return $linkurl if($linkurl =~ /:\/\//i);
my $protocol;
my $server;
my $directory;
my $filename;
# $url =~ /^(.*?:\/\/)([^\/]+?)([^\?\&]*?)([^\/]*?)$/i;
$url =~ /^(.*?:\/\/)([^\/]+?)(\/|$)(.*?)([^\/]*?)$/i;
$protocol = $1;
$server = $2;
$directory = "/$4";
$filename = $5;
if($directory =~ /[\?\&]/) {
$directory =~ /^(.*?)([\?\&].*$)/;
$directory = $1;
my $res1 = $2;
$directory =~ /^(.*)\/([^\/]*?)$/;
$directory = $1;
my $res2 = $2;
$filename = "$res2$res1$filename";
}
#print "URL : $url\n";
#print "pro : $protocol\n";
#print "server: $server\n";
#print "dir : $directory\n";
#print "file : $filename\n";
my $path;
if($linkurl =~ /^\//) {
$path = Utils::MakePath($server, $linkurl, "/", 0);
}
else {
$path = Utils::MakePath($server, $directory, "/", 0);
$path = Utils::MakePath($path, $linkurl, "/", 0);
&ReduceDirectory($path);
}
#print "path: $path\n";
$convurl = "$protocol$path";
return $convurl;
}
sub GetURLwithoutFilePath {
my ($url) = @_;
my $ret;
#CGIの場合はそのままreturn
return 1 if($url =~ /$CGIFiles/i or $url =~ /[\?\&]/);
for(my $i = 0 ; $i < @IndexFiles ; $i++) {
my $s = Utils::MakePath($url, $IndexFiles[$i], "/", 0);
#print "url: $s\n";
$ret = head($s);
# $ret = get($s);
if($ret) {
$_[0] = $s;
return $ret;
}
}
return $ret;
}
sub DownloadFromURL
{
my ($url) = @_;
my $Content;
my $agent = LWP::UserAgent->new;
my $newagent = 'Mozilla/4.7 [en] (PalmOS)';
$agent->agent($newagent);
my $jar = $agent->cookie_jar(new HTTP::Cookies);
my $request = HTTP::Request->new(GET => $url);
my $response = $agent->request($request);
unless($response->is_success) {
my $s = $response->message;
print "Error: $s!
\n";
return -1;
}
$Content = $response->content;
&ConvertHTMLToFullURL($Content, $url, 0);
return $Content;
}
sub ExtractHTMLBody
{
my ($Content) = @_;
$Content =~ /\(.*)\<\/body\>/si;
return $1;
}
#==========================================
# 「Ultimate Perl」、ソシム発行
#==========================================
sub ReadFile
{
my $fname = @_;
open(FILE, "<$fname") or return -1;
my $str = do { local $/; ; };
close(FILE);
return $str;
}
#12文字ごとにファイルを読み込み、" "で区切って返す
sub ReadFixedColumnFile
{
my $fname = @_;
open(FILE, "<$fname") or return -1;
local $/ = \12;
local $\ = "\n";
my $str = "";
while() {
$str .= " $_";
}
close(FILE);
return $str;
}
#リストをタブ区切りで出力
sub PrintWithTab1
{
my @list = @_;
local ($") = "\t";
print "@list\n";
}
sub PrintWithTab1
{
my @list = @_;
local ($,) = "\t";
print @list . "\n";
}
#文字列を固定長で区切る
sub SplitToFixedStrs
{
my $s = @_;
my @list;
$s =~ s/(.{1,8})/push(@list,$1)/eg;
return @list;
}
#括弧で囲まれた部分をきちんと抽出
sub ExtractByParentheses
{
my $str = @_;
my $balance;
$balance = qr/\([^()]*(?:(??{$balance})[^()]*)*\)/;
my $ret = "";
while($str =~ /($balance)/g) {
$ret .= "$1\n";
}
return $ret;
}
#クレジットカードの番号をチェック
sub CheckCreditCardNumber
{
$_ = shift @_;
s/[ -]//g && split //;
return "Wrong number"
if(/\D/ || (length) |~ /^1[356]$/);
my $x;
map {
$x = 0;
map { $x += $_ } split //, $_[$_]*2;
$_[$_] = $x;
} map {
$_%2 ?() : $_;
} (length)%2..(length)-1;
$x = 0;
map { $x += $_ } @_;
return $x % 10 ?
"Wrong nubmer" :
"Correct number";
}
#タグの外側だけを置換
sub ReplaceHTMLBodyOnly
{
my ($str, $source, $target) = @_;
$str =~ s/((?:\G|>)[^<]*?)$source/$1$target/g;
return $str;
}
#OSの判定
sub GetOSName
{
reuturn $^O;
}
#Configの表示
sub PrintConfig
{
use Config;
for my $key (keys(%Config)) {
print "$key : $Config{$key}\n";
}
}
#コマンドをサブルーチンでつかう
#sub AUTOLOAD
#{
# my $program = $AUTOLOAD;
##パッケージ名をはずす
# $program =~ s/.*:://;
# qx/$program @_/;
#}
#関数のオーバーライド
#use subs qw(lc uc); など
#データ中のHTMLタグを無力化
sub InvalidateHTMLTags
{
my ($input) = @_;
$input =~ s/&/&/g;
$input =~ s//>/g;
$input =~ s/"/"/g;
$input =~ s/'/'/g;
return $input;
}
#URLから危険な要素を排除
sub GetSafeURL
{
my $url = @_;
return '' if($url =~ m|[^;/?:@&=+\$,A-Za-z0-9\-_.!~*'()%]|);
if($url =~ /^([A-Za-z][A-Za-z0-9+\-.]*):/) {
my $scheme = lc($1);
my $allowed = 0;
$allowed = 1 if($scheme eq 'http');
$allowed = 1 if($scheme eq 'https');
$allowed = 1 if($scheme eq 'mailto');
return '' if(not $allowed);
}
$url =~ s/&/&/g;
$url =~ s/'/'/g;
return $url;
}
#ファイル名のチェック（ヌル文字がある場合、ディレクトリィトラバーサルがある場合は０
sub CheckSecureFileName
{
my $fname = @_;
return 0 if($fname =~ <\.\./>);
return 0 if($fname =~ /\0/);
return 1;
}
#タイムアウトの設定
#alarm(20); #20秒
#SIG{ALRM} = 'time_out';
#sub time_out {
# print "Time out\n";
# return;
#}
1;