config root man

package ADN::Utility;
#
# Utility.pm:
#

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// use Module
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

use strict;
use Exporter;
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );

use Email::Valid;
use Mail::Address;
use Jcode;
use Time::Local;

use ADN::MIME;

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Exporting
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

@ISA       = qw( Exporter );
$VERSION   = 1.00;

@EXPORT    = qw( query date2utime utime2date htmlchars sqlchars );
@EXPORT_OK = qw( );

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Form)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

    #// ----------------------------------------------------------
    #// query
    #//
    #//   引数  なし
    #//
    #//   戻値  $value (ハッシュリファレンス)
    #// ----------------------------------------------------------

sub query {
    my $mpath = shift;
    my $ref0  = _query0();

    my ($ref1, $fs_n, $fs_v) = ($$ref0 =~ /\r\n/)
                               ? _mform($ref0, $mpath) : _form($ref0);

    if (!defined $fs_n) { $fs_n = ''; }
    if (!defined $fs_v) { $fs_v = ''; }

    my $value = {
        fs_n   => $fs_n,
        fs_v   => $fs_v,
        string => $$ref0,
        form   => $ref1,
    };

    return $value;
}

sub _query0 {
    my $query = '';

    if ($ENV{'REQUEST_METHOD'}) {
        if ($ENV{'REQUEST_METHOD'} =~ /POST/i) {
            read(STDIN, $query, $ENV{'CONTENT_LENGTH'});
        }

        if ($ENV{'REQUEST_METHOD'} =~ /GET/i) {
            $query = $ENV{'QUERY_STRING'};
        }
    }

    return \$query;
}

sub _form {
    my $ref   = shift;
    my @pairs = split(/&/, $$ref);

    my %FORM  = (); my %num  = (); my $array = {};
    my $num   = 0;  my $fs_n = ''; my $fs_v  = '';

    foreach my $pair (@pairs) {
        my ($name, $value) = split(/=/, $pair);

        $value = urldecode($value);

        if (exists $FORM{$name}) {   #// SELECT MULTIPLE, CHECKBOX 等
            if ($num{$name} == 1) {
                $array->{$name}->[0] = $FORM{$name};
            }

            $array->{$name}->[$num{$name}] = $value;
            $FORM{$name} = $array->{$name};   #// 配列リファレンス
            $num{$name} += 1;

        } else {
            $num{$name}  = 1;
            $FORM{$name} = '';
            $FORM{$name} = $value;

            if ($num == 0) { $fs_n = $name; $fs_v = $value; }
            $num += 1;
        }
    }

    return (\%FORM, $fs_n, $fs_v);
}

sub _mform {
    my ($ref, $mpath) = @_;

    unless ($mpath && -e $mpath) { $mpath = '/tmp/mform/'; }
    $mpath =~ s/\/$//g; $mpath .= '/';

    $$ref =~ /^(.+)\r\n/;
    my $bound = $1;

    $$ref =~ s/$bound--\r\n$//g;
    my @pairs = split(/$bound\r\n/, $$ref);

    my %FORM  = (); 

    my $n = 0;
    foreach my $pair (@pairs) {
        next if ($pair eq '');

        if ($pair =~ /^Content-Disposition: form-data/ &&
            $pair =~ /filename=/) {

            #// form.element.name, filename

            $pair =~ /name="(.+)"; filename="(.+)"/;
            my $name = $1; my $filename = $2;

            next unless ($name);

            #// Windows path cut

            if ($filename =~ /\\/) {
                my @file = split(/\\/, $filename);
                $filename = pop(@file);
            }

            $pair =~ /Content-Type: (.+)\r\n/;
            my $type = $1;

            $pair =~ s/^Content-Disposition:(.+)\r\n//;
            $pair =~ s/^Content-Type:(.+)\r\n\r\n//;
            $pair =~ s/\r\n$//;

            my $path = $filename;

            if ($path =~ /[\xa1-\xf4][\xa1-\xfe]/ ||
                $path =~ /\x8e[\xa1-\xdf]/)
            {
                $path = 'attach' . $n;
                $n++;
            }

            $path = $mpath . $path;
            open  FILE, "+>$path";
            print FILE $pair;
            close FILE;

            $FORM{$name} = '';
            $FORM{$name} = "$type,$path,$filename";

        } else {
            $pair =~ /name="(.+)"/;
            my $name = $1;

            $pair =~ s/^Content-Disposition:(.+)\r\n\r\n//;
            $pair =~ s/\r\n$//;

            $FORM{$name} = '';
            $FORM{$name} = $pair;
        }
    }

    return \%FORM;
}

    #// ----------------------------------------------------------
    #// dump_array
    #//
    #//   引数  ($ref, $char)
    #//     $ref  : 配列リファレンス
    #//     $char : 表示時の区切り文字。(初期値 ,)
    #//
    #//   戻値  $line
    #// ----------------------------------------------------------

sub dump_array {
    my ($ref, $char) = @_;

    my $line = '';
    if (!defined $char) { $char = ','; }

    foreach (@$ref) { $line .= $_ . "$char"; }
    $line =~ s/$char$//;

    return $line;
}

    #// ----------------------------------------------------------
    #// dump_hash
    #//
    #//   引数  ($ref, $char)
    #//     $ref  : ハッシュリファレンス
    #//     $char : 1 項目毎の表示時の区切り文字。(初期値 \n)
    #//
    #//   戻値  $line
    #// ----------------------------------------------------------

sub dump_hash {
    my ($ref, $char) = @_;

    my $line = '';
    if (!defined $char) { $char = '\n'; }

    foreach (sort %$ref) {
        next unless (defined $ref->{$_});

        $line .= "$_ => " .  $ref->{$_} . "$char";
    }

    return $line;
}

    #// ----------------------------------------------------------
    #// read_conf
    #//
    #//   引数  $file (変数名 + タブ + 値 / 1 行 形式)
    #//
    #//   戻値  $conf (ハッシュリファレンス)
    #// ----------------------------------------------------------

sub read_conf {
    my $file = shift;

    open CONF, "<$file";
    my @conf = <CONF>;
    close CONF;

    my $conf = {};
    foreach (@conf) {
        chomp;

        next if ($_ =~ /^#/);
        next if ($_ eq '');
        next if ($_ !~ /\t/);

        $_ =~ s/^([\s\t]+)//g;
        $_ =~ s/(\t+)/\t/g;

        my ($key, $value) = split(/\t/);
        $conf->{$key} = $value;
    }

    return $conf;
}

    #// ----------------------------------------------------------
    #// merge_conf
    #//
    #//   引数  @conf (ハッシュリファレンスの配列)
    #//
    #//   戻値  $conf (ハッシュリファレンス)
    #// ----------------------------------------------------------

sub merge_conf {
    my @conf = @_;
    my $conf = {};

    foreach my $conf0 (@conf) {
        foreach (%$conf0) {
            next unless (defined $conf0->{$_});

            $conf->{$_} = $conf0->{$_};
        }
    }

    return $conf;
}

    #// ----------------------------------------------------------
    #// iMA
    #// ----------------------------------------------------------

sub get_seq {
    my ($ref, $filename, $mode) = @_;
    my $seq = '';

    unless ($mode) { $mode = 0; }

    foreach my $line (@$ref) {
        $line =~ s/^(\s+)//g;

        if ($mode == 0) {
            $line =~ s/^\[([a-zA-Z0-9\-\/\_]+)([\.\: ]+)([0-9]+)\](.*)/$3/;
        } else {
            $line =~ s/^([a-zA-Z0-9\-\/\_]+)([\.\: ]+)([0-9]+)(.*)/$3/;
        }

        $line =~ s/^(0+)//g;

        if ($line =~ /^(\d+)$/) {
            $seq = $line;
            last;
	}
    }

    if ($mode == 0 && $seq eq '') { return $seq; }

    if ($seq eq '') { $seq = $filename; }

    return $seq;
}

sub get_mtime {
    my $num = 0;   #// Received

    my ($ref, $date, $target, $flag) = @_;
    unless ($flag) { $flag = 0; }

    my @received  = @$ref;
    my $rec_count = $#received + 1;

    my $utime = '';
    if ($rec_count >= 1) {
        my $date0 = '';

        $date0 = $received[$num];
        $date0 =~ s/(.+)([\;\, ]+)(\d+) ([a-zA-Z]{3}) (\d+) (.+)/$3 $4 $5 $6/;

        $utime = date2utime0($date0);

    } else {
        if ($date eq "") {
            my @stat = stat $target;
            $utime = $stat[9];

        } else {
            $date =~ s/([a-zA-Z]+),//;
            $utime = date2utime0($date, $flag);
        }
    }

    return $utime;
}

sub dirname {
    my $date = shift;
    my $mdir = '';

    $mdir = substr($date, 0, 7);
    $mdir  =~ s/\//-/;

    return $mdir;
}

sub mail_name {
    my $target = shift;

    $target =~ s/<.+>//;
    return $target;
}

sub cut_maddr {
    my ($target, $mode) = @_;

    my $d3      = '\d{1,3}';
    my $ip      = join('\.', ($d3) x 4);
    my $account = '[\x01-\x7F]';
    my $domain  = '([-a-zA-Z0-9]+\.)*[a-zA-Z]+';

    if ($mode == 1) {
        $target =~ s/($account)\@($domain|\\[$ip\\])/_cut_maddr($1, $2)/geo;

    } elsif ($mode == 2) {
        $target =~ s/($account)\@($domain|\\[$ip\\])/$1/g;

    } else {
        $target =~ s/($account)\@($domain|\\[$ip\\])/$1\.$2/g;

    }

    return $target;
}

sub _cut_maddr {
    my ($account, $domain) = @_;

    $domain =~ s/[^\.]/-/g;
    return $account . '@' . $domain;
}

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Convert)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

    #// ----------------------------------------------------------
    #// Convert URL
    #// ----------------------------------------------------------
    
sub urldecode {
    my $target = shift;

    $target =~ tr/+/ /;
    $target =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("C", hex($1))/eg;

    return $target;
}

sub urlencode {
    my $target = shift;

    $target =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
    $target =~ tr/ /+/;

    return $target;
}

    #// ----------------------------------------------------------
    #// Convert Chars (euc-jp)
    #// ----------------------------------------------------------

sub convert_base {
    my $target = shift;

    $target = Jcode->new($target)->tr('　', ' ')->euc;

    $target =~ s/(\t+)/ /g; $target =~ s/(\s+)/ /g;

    $target =~ s/^\s//g; $target =~ s/\s$//g;
    $target =~ s/^"//g;  $target =~ s/"$//;

    return $target;
}

sub z2asc {
    my $target = shift;

    return $target if (ref($target) eq 'ARRAY');

    # 未対応 => ＋−ー

    my $sign0 = '！”＃＄％＆’（）＊／：；＜＝＞？＠．';
    my $sign1 = '!"#$%&\'()*/:;<=>?@.';

    $target = Jcode->new($target)
                   ->tr('０-９ａ-ｚＡ-Ｚ', '0-9a-zA-Z')
                   ->tr($sign0, $sign1)
                   ->tr('　', ' ')->euc;

    return $target;
}

    #// ----------------------------------------------------------
    #// Convert Chars (HTML)
    #// ----------------------------------------------------------

sub htmlbody {
    my $target = shift;

    $target =~ s/&quot;/"/g;
    $target =~ s/&amp;/&/g;

    $target =~ s/(http|ftp|https):\/\/([0-9a-zA-Z\#\$\%\&\+\-\.\,\/\:\=\?\@\\\^\_\`\{\|\}\~]+)/<a href=\"$1:\/\/$2\">$1:\/\/$2<\/a>/g;

    $target =~ s/&gt\">/\">/g;
    $target =~ s/&gt<\/a>;/<\/a>&gt;/g;
    $target =~ s/&lt<\/a>;/<\/a>&lt;/g;

    return $target;
}

sub htmlchars {
    my $target = shift;

    $target =~ s/&/&amp;/g;
    $target =~ s/"/&quot;/g;
    $target =~ s/</&lt;/g;
    $target =~ s/>/&gt;/g;

    return $target;
}

sub rev_htmlchars {
    my $target = shift;

    $target =~ s/&lt;/</g;
    $target =~ s/&gt;/>/g;
    $target =~ s/&quot;/"/g;

    return $target;
}

sub lf2br {
    my ($target, $char) = @_;
    $char = (defined $char) ? 1 : 0;

    my $br = ($char == 1) ? '<br>' : '<br />';
    $target =~ s/\n/$br/g;

    return $target;
}

sub br2lf {
    my ($target, $char) = @_;
    $char = (defined $char) ? 1 : 0;

    my $br = ($char == 1) ? '<br>' : '<br />';
    $target =~ s/$br/\n/g;

    return $target;
}

sub untag {
    my $target = shift;
    if (!defined $target) { $target = ''; }

    my $result = '';

    my $tag_regex0    = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))};
    my $comment_regex = q{<!(?:--(?:(?!--).)*--\s*)*>};

    my $tag_regex     = qq{$comment_regex|<$tag_regex0};
    my $text_regex    = q{[^<]*};

    while ($target =~ /($text_regex)($tag_regex)?/gso) {
        last if $1 eq '' && ($2 && $2 eq '');
        $result .= $1;

        my $tag_tmp = $2;
        if ($tag_tmp && $tag_tmp =~ /^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) {
            $target =~ /(.*?)(?:<\/$1(?![0-9A-Za-z])$tag_regex0|$)/gsi;

            my $text_tmp = $1;
            $text_tmp =~ s/</&lt;/g; $text_tmp =~ s/>/&gt;/g;
            $result .= $text_tmp;
        }
    }

    return $result;
}

    #// ----------------------------------------------------------
    #// Convert Chars (SQL)
    #// ----------------------------------------------------------

sub sqlchars {
    my $target = shift;

    $target =~ s/\\/\\\\/g; $target =~ s/\'/\\\'/g;
    $target =~ s/\?/\\\?/g; $target =~ s/\*/\\\*/g;
    $target =~ s/\$/\\\$/g; $target =~ s/\|/\\\|/g;
    $target =~ s/\[/\\\[/g; $target =~ s/\]/\\\]/g;
    $target =~ s/\^/\\\^/g; $target =~ s/\;/\\\;/g;

    return $target;
}

sub shquery {
    my $target = shift;

    $target =~ s/'/'"'"'/g;
    $target = "'$target'";

    return $target;
}

    #// ----------------------------------------------------------
    #// Convert Chars (sh)
    #// ----------------------------------------------------------

sub shchars {
    my $target = shift;

    $target =~ s/\\/\\\\/g; $target =~ s/\-/\\\-/g;
    $target =~ s/\?/\\\?/g; $target =~ s/\*/\\\*/g;
    $target =~ s/\$/\\\$/g; $target =~ s/\|/\\\|/g;
    $target =~ s/\&/\\\&/g; $target =~ s/\;/\\\;/g;
    $target =~ s/\(/\\\(/g; $target =~ s/\)/\\\)/g;
    $target =~ s/\[/\\\[/g; $target =~ s/\]/\\\]/g;

    $target =~ s/\^/\\\\\\\^/g;

    return $target;
}

sub regchars {
    my $target = shift;

    $target =~ s/\\/\\\\/g;

    $target =~ s/\?/\\\?/g; $target =~ s/\*/\\\*/g;
    $target =~ s/\+/\\\+/g;

    $target =~ s/\$/\\\$/g; $target =~ s/\|/\\\|/g;

    $target =~ s/\(/\\\(/g; $target =~ s/\)/\\\)/g;
    $target =~ s/\[/\\\[/g; $target =~ s/\]/\\\]/g;

    $target =~ s/\^/\\\^/g;

    $target =~ s/\{/\\\{/g; $target =~ s/\}/\\\}/g;
    $target =~ s/\//\\\//g; $target =~ s/\./\\\./g;

    return $target;
}

    #// ----------------------------------------------------------
    #// Convert Chars (Time)
    #// ----------------------------------------------------------

sub date2utime {
    my $date = shift;

    $date =~ s/[\/:]/ /g;
    $date =~ s/^(\s+)//g; $date =~ s/(\s+)$//g;
    $date =~ s/(\s+)/ /g;

    my ($year, $mon, $mday, $hour, $min, $sec) = split(/ /, $date);

    if (!defined $sec) { $sec = 0; }
    $mon -= 1;

    eval { timelocal($sec, $min, $hour, $mday, $mon, $year); };
    if ($@) { return 0; }

    my $utime = timelocal($sec, $min, $hour, $mday, $mon, $year);

    return $utime;
}

sub date2utime0 {   #// Mail Header 'Date' Exchange
    my ($date, $flag) = @_;
    unless ($flag) { $flag = 0; }

    $date =~ s/:/ /g;
    $date =~ s/([\s\t]+)/ /g;
    $date =~ s/^(\s+)//g;
    $date =~ s/(\s+)/ /g;
    $date =~ s/^([a-zA-Z,]+) //g;

    my $mon  = '';
    my $mday = '';
    my $hour = '';
    my $min  = '';
    my $sec  = '';
    my $year = '';
    my $lag  = '';
    my $null = '';

    if ($flag == 1) {   #// # Apache-XXX mailman
        ($mon, $mday, $hour, $min, $sec, $year, $lag) = split(/ /, $date);

    } elsif ($flag == 2) {
        ($mon, $mday, $year, $hour, $min, $sec, $lag) = split(/ /, $date);

    } else {
        ($mday, $mon, $year, $hour, $min, $sec, $lag, $null) = split(/ /, $date);
    }

    #// Month Convert

    my @mon = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );

    my $count = 0;
    foreach (@mon) {
        if ($mon eq $_) {
            $mon = $count;
            last;
        }
        $count += 1;
    }

    #// Time Lag Commit

    if (!defined $lag || $lag eq '') { $lag = '0900'; }

    if ($lag =~ /0900/ || $lag =~ /JST/i) {
        $lag = 0;

    } else {
        if ($lag =~ /GMT/i) { $lag = 0; }

        $lag = 900 - $lag;
        $lag =~ s/00$//;
        $lag = $lag * 60 * 60;
    }

    #// Start

    eval { timelocal($sec, $min, $hour, $mday, $mon, $year); };
    if ($@) { return 0; }

    my $utime = timelocal($sec, $min, $hour, $mday, $mon, $year) + $lag;

    return $utime;
}

sub utime2date {
    my ($sec, $min, $hours, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($_[0]);

    my $years    = $year + 1900;
    my $this_mon = sprintf("%02d",$mon + 1);

    $mday  = sprintf("%02d", "$mday");
    $hours = sprintf("%02d", "$hours");
    $min   = sprintf("%02d", "$min");
    $sec   = sprintf("%02d", "$sec");

    my $date = "$years/$this_mon/$mday $hours:$min:$sec";

    return $date;
}

    #// ----------------------------------------------------------
    #// Convert Cookie
    #// ----------------------------------------------------------

sub get_cookie {
    my $data = {};

    if ($ENV{HTTP_COOKIE}) {
        my @cookie = split(/; /, $ENV{HTTP_COOKIE});

        foreach (@cookie) {
            my ($key, $value) = split(/=/);

            $data->{$key} = $value;
        }
    }

    return $data;
}

sub utime2cookie {
    my ($sec, $min, $hours, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($_[0]);

    my $years = $year + 1900;
    my @month = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
    my $month = $month[$mon];

    my @wday  = qw( Sun Mon Tue Wed Thr Fri Sat );
    my $weekd = $wday[$wday];

    $mday  = sprintf("%02d", "$mday");
    $hours = sprintf("%02d", "$hours");
    $min   = sprintf("%02d", "$min");
    $sec   = sprintf("%02d", "$sec");

    my $date = "$weekd, $mday-$month-$years $hours:$min:$sec GMT";

    return $date;
}

    #// ----------------------------------------------------------
    #// Convert Chars (CSV)
    #// ----------------------------------------------------------

sub csv_make {
    my $target = shift;
    my $result = '';

    $result = join ',', map {(s/"/""/g or /[\r\n,]/) ? qq("$_") : $_} split(/\t/, $target);

    return $result;
}

sub csv_get {
    my $line = shift;
    my $tmp  = $line;

    $tmp =~ s/(?:\x0d\x0a|[\x0d\x0a])?$/,/;
    my @values = map {/^"(.*)"$/s ? scalar($_ = $1, s/""/"/g, $_) : $_}
                 ($tmp =~ /("[^"]*(?:""[^"]*)*"|[^,]*),/g);

    return @values;
}

sub csv_mget {
#http://www.din.or.jp/~ohzaki/perl.htm#CSVwithCRLF
}

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Exchange)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

    #// ----------------------------------------------------------
    #// Text Line
    #// ----------------------------------------------------------

sub txt_make {
    my ($blank, $length, $line0) = @_;

    my $space = ' ' x $blank;
    my $line  = '';

    if ($line0 =~ /\n/) {
        #// 対象文字列に改行コードが含まれている場合

        foreach (split(/\n/, $line0)) {
           $line .= _txt_make($blank, $length, $_) . "\n";
        }

        $line =~ s/\n$space$//;
        1 while $line =~ s/\n$space\n/\n\n/;

    } else {
        $line = _txt_make($blank, $length, $line0);
    }

    $line =~ s/(\n+)$//;
    return $line;
}

sub _txt_make {
    my ($blank, $length, $line0) = @_;

    my $count = $blank; my $mbyte = 1;
    my $space = ' ' x $blank;
    my $line  = $space;

    foreach (split(//, $line0)) {
        $line .= $_;

        if ($_ =~ /[\x20-\x7e]/) { $count += 1; }

        if ($_ =~ /[\xa1-\xfe]/) {
            if ($mbyte == 2) {
                $count += 2;
                $mbyte = 1;
            } else {
                $mbyte += 1;
            }
        }

        if ($count >= $length) {
            $line .= "\n" . $space;
            $count = $blank;
        }
    }

    return $line;
}

    #// ----------------------------------------------------------
    #// Comma Separete
    #// ----------------------------------------------------------

sub comma {
    my $target = shift;

    1 while $target =~ s/(\d)(\d\d\d)(?!\d)/$1,$2/g;

    return $target;

}

    #// ----------------------------------------------------------
    #// Form Size
    #// ----------------------------------------------------------

#// see: http://www.futomi.com/lecture/env_var/http_user_agent.html

sub txt_size {
    my $default = shift;
    my $size = 0;

    if ($ENV{'HTTP_USER_AGENT'} =~ /MSIE/) {
        if ($ENV{'HTTP_USER_AGENT'} =~ /Opera/) {
            $size = $default * 0.7;
        } else {
            $size = $default * 1.1;
        }

    } else {
        if ($ENV{'HTTP_USER_AGENT'} =~ /Netscape/) {   #// 7.x
            if ($ENV{'HTTP_USER_AGENT'} =~ /Linux/i) {
                $size = $default * 0.75;
	    } else {
                $size = $default * 1.1;
	    }

	} else {   #// 4.x
            $size = $default * 0.8;
        }
    }

    return int($size);
}

    #// ----------------------------------------------------------
    #// HTTP Header
    #// ----------------------------------------------------------

sub http_header {
    print "Content-Type: text/html;\n\n";
}

#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Mail)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

sub mail_attach {
    my ($bound, $ref0, $ref1, $html, $reserve) = @_;

    my $body   = $$ref0;
    my $attach = '';

    unless ($html)    { $html = 0; }
    unless ($reserve) { $reserve = 0 };

    #// Body

    my $h_body = "--$bound\n";
    $h_body   .= "Content-Type: text/plain; charset=iso-2022-jp\n";
    $h_body   .= "Content-Transfer-Encoding: 7bit\n\n";

    $body = $h_body . $body . "\n\n";

    #// Attach

    foreach (%$ref1) {
        my $target = $ref1->{$_};
        next unless ($target);

        my $name = ADN::MIME::HeaderEncode($target->{FILE});

        my $h_attach = "--$bound\n";
        $h_attach   .= "Content-Type: $target->{TYPE}";

        if ($html == 0) {
            $h_attach   .= ";\n";
            $h_attach   .= " name=\"$name\"\n";

            $h_attach   .= "Content-Disposition: attachment;\n";
            $h_attach   .= " filename=\"$name\"\n";
        }

        if ($html == 1) {
            $h_attach   .= "\n";
        }

        $h_attach .= "Content-Transfer-Encoding: base64\n\n";
        my $file   = `cat $target->{PATH}`;

        if ($reserve == 0) { `rm $target->{PATH}`; }

        my $body0 = ADN::MIME::BodyEncode($file, 'b64');

        $attach .= $h_attach . $body0 . "\n\n";
    }

    #// Join

    $body .= $attach . "--$bound--\n";

    return \$body;
}

    #// ----------------------------------------------------------
    #// Send
    #// ----------------------------------------------------------

sub mail_send {
    my ($mta, $header, $body) = @_;

    #// Open

    open MAIL, "| $mta";

    #// Header

    foreach (%$header) {
        next unless ($header->{$_});

        print MAIL $_ . ": " . ADN::MIME::HeaderEncode($header->{$_}) . "\n";
    }

    print MAIL "\n";

    #// Mail Body

    print MAIL Jcode::convert($body, 'jis');

    #// Close

    close MAIL;
}

    #// ----------------------------------------------------------
    #// mail_check
    #//
    #//   引数  $target (メールアドレス)
    #//
    #//   戻値  (\@error, $target)
    #//     \@error : エラーコードの配列リファレンス
    #//     $target : 引数を整形したメールアドレス
    #//               (複数時は addr1, addr2 の書式に整形)
    #// ----------------------------------------------------------

sub mail_check {
    my ($target, $account_check) = @_;

    my @error = ();
    my @addr  = Mail::Address->parse($target);
    my $maddr = '';

    unless ($account_check) { $account_check = 0; }

    foreach my $addr (@addr) {
        $maddr .= $addr->format . ', ';

        my $check = 0;

        if ($account_check == 1) {
            $check = (Email::Valid->address($addr->address) ? 0 : 1);
        }
        if ($check == 0) { $check = (Email::Valid->mx($addr->address) ? 0 : 2); }

        unless ($check == 0) {
            my $msg = $addr->address . "\t$check";
            push(@error, $msg);
        }
    }

    $maddr =~ s/, $//;

    return (\@error, $maddr);
}

1;