#!/usr/bin/perl
#
# $Id: lib-HDcgi.pl,v 1.26 2017/03/23 06:35:22 doi Exp $
# HD cgi library
#
# -------------------------------------------------------------------------
#

sub get_filelist
{
    opendir LD, $_[0];
    my @lout = readdir LD;
    closedir LD;
    my @out = ();
    foreach my $f (@lout) {
        next if (substr($f, 0, 1) eq '.');
        push @out, $f;
    }
    return sort @out;
}

sub js_encode
{
    my $l = $_[0];
    $l =~ s/\\/\\\\/g;
    $l =~ s/\'/\\\'/g;
    $l =~ s/\"/\\\"/g;
    return $l;
}

sub html_encode
{
    my $v = $_[0];
    my @x = unpack('C*', $v);
    my $e = '';
    while (scalar @x > 0) {
        my $l = shift @x;
        if ($l >= 0x30 && $l <= 0x39) { $e .= chr($l); }
        elsif ($l == 0x22) { $e .= '&quot;'; }
        elsif ($l == 0x3c) { $e .= '&lt;'; }
        elsif ($l == 0x3e) { $e .= '&gt;'; }
        # very cautious: encode all ascii printables
        elsif ($l > 0x20 && $l < 0x80) { $e .= sprintf '&#x%02x;', $l; }
        else { $e .= chr($l); }
    }
    return $e;
}

sub html_decode
{
    my $v = $_[0];
    my @x = unpack('C*', $v);
    my $r = '';
    while (scalar @x > 0) {
        my $l = shift @x;
        if ($l != 0x26) {  # not &
            $r .= chr($l);
            next;
        }
        # found &
        my $ins = '';
        while (scalar @x > 0) {
            $l = shift @x;
            last if ($l == 0);
            last if ($l == 0x3b);  # ;
            $ins .= chr($l);
        }
        if ($l == 0 || scalar @x == 0) {  # end of string
            $r .= $ins;
            next;
        }
        # found ;
        if ($ins eq 'quot') { $r .= '"'; }
        elsif ($ins eq 'lt') { $r .= '<'; }
        elsif ($ins eq 'gt') { $r .= '>'; }
        elsif ($ins eq 'amp') { $r .= '&'; }
        elsif ($ins eq 'nbsp') { $r .= ' '; }
        elsif (substr($ins, 0, 2) eq '#x') {
            substr($ins, 0, 2) = '';
            $r .= sprintf "%c", hex($ins);
        }
        else {
            $r .= '&' . $ins . ';';
        }
    }
    return $r;
}

sub url_encode
{
    my $u = $_[0];
    my @x = unpack('C*', $u);
    my $v = '';
    while (scalar @x > 0) {
        my $l = shift @x;
        if ($l == 0x20) {
            $v .= '+';
        }
        elsif ($l < 0x21 || $l > 0x7E) {
            $v .= '%' . sprintf "%02x", $l;
        }
        elsif ($l == 0x26 || $l == 0x25 || $l == 0x23 || $l == 0x2b ||
            $l == 0x5d || $l == 0x5b || $l == 0x3c || $l == 0x3e ||
            $l == 0x22 || $l == 0x3f || $l == 0x7b || $l == 0x7d) {
            $v .= '%' . sprintf '%02x', $l;
        }
        else {
            $v .= chr($l);
        }
    }
    return $v;
}

sub xml_encode
{
    my $s = $_[0];
    $s =~ s/\&/\&amp;/g;
    $s =~ s/[\001-\037]//g;
    $s =~ s/\"/\&quot;/g;
    $s =~ s/\</\&lt;/g;
    $s =~ s/\>/\&gt;/g;
    $s =~ s/\'/\&apos;/g;
    return $s;
}

#
# return number of utf8 chars in string
#
sub utf8chars
{
    my $s = $_[0];
    my @x = unpack('C*', $s);
    my $uct = 0;
    while (scalar @x > 0) {
        my $uc = shift @x;
        $uct++;
        if ($uc < 0x80) {
            next;
        }
        if ($uc < 0xe0) {
            shift @x;
            next;
        }
        if ($uc < 0xf0) {
            shift @x; shift @x;
            next;
        }
        if ($uc < 0xf8) {
            shift @x; shift @x; shift @x;
            next;
        }
        if ($uc < 0xfc) {
            shift @x; shift @x; shift @x; shift @x;
            next;
        }
        shift @x; shift @x; shift @x; shift @x; shift @x;
    }
    return $uct;
}

#
# utf8chop(string, leng)
#  chop utf8 string at character boundary (nearest len bytes)
#
sub utf8chop
{
    my $s = $_[0];
    my $p = $_[1] - 1;
    my @x = unpack('C*', $s);
    while ($x[$p] >= 0x80 && $x[$p] <= 0xBF) {
        $p--;
    }
    my $r = '';
    my $i;
    for ($i = 0; $i < $p; $i++) {
        next if ($x[$i] == 0);
        $r .= pack('C', $x[$i]);
    }
    return $r;
}

#
# utf8check(string)
#  return position (start=0) of first invalid character
#  returns -1 if valid utf8
#
sub utf8check
{
    my $s = $_[0];
    my @x = unpack('C*', $s);
    my $p = -1;  # position
    while (scalar @x > 0) {
        my $uc = shift @x;
        $p++;
        if ($uc <= 0x7f) {  # one byte
            next;
        }
        my $nextb = 0;
        if ($uc >= 0xc0 && $uc <= 0xdf) {  # two byte
            $nextb = 1;
        }
        elsif ($uc >= 0xe0 && $uc <= 0xef) {  # three byte
            $nextb = 2;
        }
        elsif ($uc >= 0xf0 && $uc <= 0xf7) {  # four byte
            $nextb = 3;
        }
        elsif ($uc >= 0xf8 && $uc <= 0xfb) {  # five byte
            $nextb = 4;
        }
        elsif ($uc >= 0xfc && $uc <= 0xfd) {  # six byte
            $nextb = 5;
        }
        return $p if ($nextb == 0);  # invalid first byte
        foreach my $bct (1 .. $nextb) {
            $uc = shift @x;
            $p++;
            return $p if ($uc < 0x80 || $uc > 0xbf);
        }
    }
    return -1;
}

sub ascii_only
{
    my $l = $_[0];
    my @x = unpack('C*', $l);
    foreach my $c (@x) {
        return 0 if ($c >= 0x80);
    }
    return 1;
}

#
# dayofweek(YYYY, MM, DD)
#  return day of week: sun=0, mon=1, tue=2, etc..
#  this algorithm good between 2002.01.01 and 2099.12.31
#
sub dayofweek
{
    my ($y0, $m0, $d0) = @_;
    $m_off{'01'} = 0;
    $m_off{'02'} = 31;
    $m_off{'03'} = 59;
    $m_off{'04'} = 90;
    $m_off{'05'} = 120;
    $m_off{'06'} = 151;
    $m_off{'07'} = 181;
    $m_off{'08'} = 212;
    $m_off{'09'} = 243;
    $m_off{'10'} = 273;
    $m_off{'11'} = 304;
    $m_off{'12'} = 334;
    my $ydiff = $y0 - 2002;
    my $ddiff = int(($y0 - 2001) / 4);
    if (!($y0 % 4) && ($m0 > 2)) { $ddiff++; }
    $m0 = sprintf "%02d", $m0;
    $days = 365 * $ydiff + $m_off{$m0} + $d0 + $ddiff + 1;
    # +1 2002.01.01
    return $days % 7;
}

#
# lastdayofmonth(YYYY, MM)
#
sub lastdayofmonth
{
    my $y0 = int($_[0]);
    my $m0 = int($_[1]);
    if ($m0 == 2) {
        return 29 if ($y0 % 400 == 0);
        return 28 if ($y0 % 100 == 0);
        return 29 if ($y0 % 4 == 0);
        return 28;
    }
    return (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$m0 - 1];
}

#
# prevdate(YYYY-MM-DD)
#
sub prevdate
{
    my $dt = $_[0];
    my ($yy, $mm, $dd) = split(/-/, $dt);
    $dd--;
    if (int($dd) <= 0) {
        $mm--;
        if (int($mm) <= 0) {
            $yy--;
            $mm = 12;
        }
        $dd = &lastdayofmonth($yy, $mm);
    }
    return sprintf "%4d-%02d-%02d", $yy, $mm, $dd;
}

#
# nextdate(YYYY-MM-DD)
#
sub nextdate
{
    my $dt = $_[0];
    my ($yy, $mm, $dd) = split(/-/, $dt);
    $dd++;
    my $last = &lastdayofmonth($yy, $mm);
    if (int($dd) > $last) {
        $dd = 1;
        $mm++;
        if (int($mm) > 12) {
            $mm = 1;
            $yy++;
        }
    }
    return sprintf "%4d-%02d-%02d", $yy, $mm, $dd;
}

#
# get last-modified date of file
#  (file, format)
#  http = dow, DD Month YYYY hh:mm:ss GMT
#  default = YYYY-MM-DD hh:mm:ss (localtime)
#
sub file_lastmodified
{
    my ($f, $fmt) = @_;  # file, format
    return '' if (! -e $f);
    my $mtime = (stat $f)[9];
    if ($fmt eq 'http') {
        my @x = gmtime($mtime);
        my $wday = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat')[$x[6]];
        my $mm = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
                  'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec')[$x[4]];
        return sprintf "$wday, %02d $mm %4d %02d:%02d:%02d GMT",
                       $x[3], $x[5] + 1900, $x[2], $x[1], $x[0];
    }
    my @x = localtime($mtime);
    return sprintf "%4d-%02d-%02d %02d:%02d:%02d",
                   $x[5] + 1900, $x[4] + 1, $x[3], $x[2], $x[1], $x[0];
}

sub read_localfile
{
    my $f = $_[0];
    return if ($f eq '');
    my $t = '';
    open LOCALF, '<', $f;
    my $l;
    while ($l = <LOCALF>) {
        $t .= $l;
    }
    close LOCALF;
    return $t;
}

sub refresh0
{
    print "<META http-equiv=refresh content=\"0;url=$_[0]\">\n";
    exit 0;
}

sub mouseover_color
{
    my $color = $_[0];
    my $p = " onMouseOver=\"this.style.background='$color'\"" .
            " onMouseOut=\"this.style.background=''\"";
    return $p;
}

#
# get contents of specified url (assuming it's text)
#  get_urltext(url, ua, cookies)
#  returns (ERRORMESSAGE, contents)
#
sub get_urltext
{
    my $u = $_[0];
    my $ua = $_[1];
    my $cookies = $_[2];
    my $outf = '/tmp/hdcurl.' . $$;
    my @ccom = ('/usr/bin/curl', '--silent', '--show-error', '--include',
                '--stderr', '-', '--output', $outf, '--url', $u);
    $ua = 'lib-HDcgi/1.0' if ($ua eq '');
    push @ccom, '--user-agent', $ua;
    if ($cookies ne '') {
        push @ccom, '--cookie', $cookies;
    }

    if (!open(CCOM, "-|")) { exec @ccom; }
    my @cout = <CCOM>;
    close CCOM;

    if ($cout[0] ne '') {
        unlink $outf;
        chop $cout[0];
        return ($cout[0]);
    }
    if (! -e $outf) {
        return ('no output');
    }
    if (!open(UOUT, '<', $outf)) {
        unlink $outf;
        return ("can't open output file");
    }
    my $l = <UOUT>;
    $l =~ s/[\r\n]//g;
    my @hh = split(/ /, $l, 2);
    if ($hh[1] !~ m/^200/) {
        close(UOUT);
        unlink $outf;
        return ('http error ' . $hh[1]);
    }
    while ($l = <UOUT>) {
        $l =~ s/[\r\n]//g;
        last if ($l eq '');
    }
    my @ret = ('', <UOUT>);
    close UOUT;
    unlink $outf;
    foreach my $l (@ret) {
        $l =~ s/\n//;
    }
    return @ret;
}

#
# get/set cookies
#  get_cookie(cookie)
#  set_cookie(cookie, value, exp[seconds])
#
sub get_cookie
{
    my $c = $_[0];
    my $cookies = $ENV{'HTTP_COOKIE'};
    foreach my $p (split(/;[ ]+/, $cookies)) {
        my ($k, $v) = split(/=/, $p, 2);
        if ($k eq $c) { return $v; }
    }
    return '';
}

sub set_cookie
{
    my $c = $_[0];
    my $v = $_[1];
    my $exp = int $_[2];
    $exp = 31536000 if ($exp <= 0);  # default one year
    my @x = gmtime(time + $exp);
    my $yy = $x[5] + 1900;
    my $mm = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
              'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec')[$x[4]];
    my $dd = sprintf "%02d", $x[3];
    my $h = sprintf "%02d", $x[2];
    my $m = sprintf "%02d", $x[1];
    print "Set-Cookie: $c=$v; expires=$dd-$mm-$yy $h:$m:00 GMT\n";
}

#
# calculate distance between two points
#  latitude1, longitude1, latitude2, longitude2 - in degrees (fractional)
#
sub gps_distance_earth
{
    my ($la1, $lo1, $la2, $lo2) = @_;
    my $lat1 = &d2r($la1);
    my $lon1 = &d2r($lo1);
    my $lat2 = &d2r($la2);
    my $lon2 = &d2r($lo2);
    my $earthr = 6371;
    my $cv = sin($lat1) * sin($lat2) +
             cos($lat1) * cos($lat2) * cos($lon1 - $lon2);
    return 0 if ($cv < -1 || $cv > 1);
    return $earthr * &acos($cv);
}

#
# calculate box surrounding point for distance
#  latitude1, longitude1 - in degrees (fractional)
#  distance - in km
#
sub gps_box_earth
{
    my ($la1, $lo1, $d) = @_;
    my $lat1 = &d2r($la1);
    my $lon1 = &d2r($lo1);
    my $earthr = 6371;
    my $x1 = &asin(sin($lat1) * cos($d / $earthr) +
                   cos($lat1) * sin($d / $earthr));
    my $y1 = $lon1 + atan2(sin($d / $earthr) * cos($lat1),
                           cos($d / $earthr) - sin($lat1) * sin($lat1));
    my $x2 = $lat1 - ($x1 - $lat1);
    my $y2 = $lon1 - ($y1 - $lon1);
    return (&r2d($x1), &r2d($y1), &r2d($x2), &r2d($y2));
}

#
# calculate geo direction of point 2 from point 1
#  input lat, lon in degrees
#  return direction in degrees N=0, E=90, S=180, W=270
#
sub geo_direction
{
    my ($la1, $lo1, $la2, $lo2) = @_;
    if ($lo2 == $lo1) {
        return 180 if ($la1 > $la2);
        return 0;
    }
    if ($la2 == $la1) {
        return 270 if ($lo1 > $lo2);
        return 90;
    }
    my $lat1 = &d2r($la1);
    my $lon1 = &d2r($lo1);
    my $lat2 = &d2r($la2);
    my $lon2 = &d2r($lo2);
    my $cv = sin($lat1) * sin($lat2) +
             cos($lat1) * cos($lat2) * cos($lon1 - $lon2);
    return 0 if ($cv < -1 || $cv > 1);
    my $cr = &acos($cv);
    my $dr = &asin(cos($lat2) * sin($lon2 - $lon1) / sin($cr));
    my $dd = &r2d($dr);  # between -90 and 90
    return 180 - $dd if ($lat1 > $lat2);
    return 360 + $dd if ($lon1 > $lon2);
    return $dd;
}

sub acos
{
    my $r = $_[0];
    return atan2(sqrt(1 - $r * $r), $r);
}

sub asin
{
    my $r = $_[0];
    return atan2($r, sqrt(1 - $r * $r));
}

sub d2r
{
    my $d = $_[0];  # degrees
    my $pi = 3.1415926535897932384626433832795029;
    return ($pi / 180) * $d;  # radians
}

sub r2d
{
    my $r = $_[0];  # radians
    my $pi = 3.1415926535897932384626433832795029;
    return (180 / $pi) * $r;  # degrees
}


#
# ct = parse_multi(boundary, buffer)
#  will parse the input of multipart/form-data
#  will set the globals:
#    @UPLOAD_varname, @UPLOAD_data, @UPLOAD_filetype, @UPLOAD_filename
#  returns the number of parts
#
sub parse_multi
{
    my $boundary = $_[0];
    my $buffer = $_[1];
    my @d = split(/\n/, $buffer);
    my $ct = 0;
    @UPLOAD_varname = ();
    @UPLOAD_data = ();
    @UPLOAD_filetype = ();
    @UPLOAD_filename = ();
    my $l;
    while ($l = shift(@d)) {
        if ($l =~ m/$boundary/) {
            my $name = shift(@d);
            my $filename = $name;
            return $ct if ($name !~ m/name=/);
            $name =~ s/.* name=\"//;
            $name =~ s/\".*//;
            if ($filename =~ m/filename=/) {
                $filename =~ s/.*filename=\"//;
                $filename =~ s/\".*//;
            }
            else {
                $filename = '';
            }
            my $type = shift(@d);
            if ($type =~ m/Content-Type:/) {
                $type =~ s/Content-Type:[ ]+//;
                shift(@d);
            }
            else {
                $type = 'UNKNOWN';
            }
            my $file = '';
            while (!(($l = shift(@d)) =~ m/$boundary/)) {
                $file .= $l . "\n";  # add LF because we split
            }
            chop $file;  chop $file;  # remove CR-LF
            unshift(@d, $l);  # put boundary back
            $UPLOAD_data[$ct] = $file;
            $UPLOAD_filetype[$ct] = $type;
            $UPLOAD_filename[$ct] = $filename;
            $UPLOAD_varname[$ct] = $name;
            $ct++ if ($name);
        }
    }
    return $ct;
}


sub google_mobile
{
    my $r = "<center>\n";
    $r .= "<script type=\"text/javascript\">\n";
    $r .= "google_ad_client = \"ca-pub-8482462949925912\";\n";
    $r .= "google_ad_slot = \"9028441554\";\n";
    $r .= "google_ad_width = 320;\n";
    $r .= "google_ad_height = 50;\n";
    $r .= "</script>\n";
    $r .= "<script type=\"text/javascript\"";
    $r .= " src=\"http://pagead2.googlesyndication.com/pagead/show_ads.js\">";
    $r .= "</script>\n";
    $r .= "</center>\n";
    return $r;
}

sub itunes_match
{
    my ($x, $y, $type, $kw) = @_;
    my $p = "<center>\n";
    $p .= "<script type=\"text/javascript\">\n";
    $p .= "bst_itunesmatch_width = $x;\n";
    $p .= "bst_itunesmatch_height = $y;\n";
    $p .= "bst_itunesmatch_type = '$type';\n";
    if ($kw ne '') {
        $p .= "bst_itunesmatch_keyword = '$kw';\n";
    }
    $p .= "</script>\n";
    $p .= "<script type=\"text/javascript\"";
    $p .= " src=\"http://akiba-search.net/TMP/bst-itunesmatch.js\">";
    $p .= "</script>\n";
    $p .= "</center>\n";
    return $p;
}

#
# functions for web seiyuu section
#
sub seiyuu_top_smartphone
{
    my $color = $_[0];
    my $bstyle = 'style="margin:0;"';
    my $fontfamily = 'font-family: arial,sans-serif';
    my $p = "<style><!-- body {$fontfamily} --></style>\n";
    $p .= "<body bgcolor=\"$color\" $bstyle>\n";
    my $seiyuulink = '/doi-bin/Viphone.pl?/seiyuu/';
    my $simg = "<img src=\"/doi/seiyuu/buttons/Viphone/b310-seiyuu2.png\">";
    $p .= "<table width=\"100%\" cellspacing=0 bgcolor=\"#c0c0c0\">";
    $p .= "<tr valign=top><td align=middle>";
    $p .= "<a href=\"$seiyuulink\">$simg</a>\n";
    $p .= "</td></tr></table>\n";
    return $p;
}

sub seiyuu_top_pc
{
    my ($color, $section) = @_;
    my $seiyuucss = '/doi/css/seiyuu.css';
    my $seiyuubase = '/home/doi/www/cgi-bin/dbinfo/seiyuu-';
    my $bstyle = 'style="max-width:1200px;"';
    my $fonts = 'font-family:arial,sans-serif;';
    $fonts .= 'font-size:18px;';
    $fonts .= 'line-height:133%;';
    my $p = "<style> body {$fonts} </style>\n";
    $p .= "<link rel=\"stylesheet\" type=\"text/css\" href=\"$seiyuucss\">\n";
    $p .= "<body bgcolor=\"$color\" $bstyle>\n";
    if ($section ne '') {
        my $sf = $seiyuubase . $section;
        $p .= &read_localfile($sf) if (-e $sf);
    }
    return $p;
}

sub seiyuu_top_table
{
    my $type = $_[0];  # smartphone|PC
    my $p = '';
    if ($type eq 'smartphone') {
    }
    else {
        $p .= "<table width=\"100%\" cellspacing=0><tr valign=top><td>\n";
    }
    return $p;
}

sub seiyuu_bottom_table
{
    my $type = $_[0];   # smartphone|PC
    my $links = $_[1];  # links above ad
    my $gtype = $_[2];  # google ad type
    my $p = '';
    if ($type eq 'smartphone') {
        $p .= "<p>\n";
        if ($gtype ne 'none') {
            $p .= &google_mobile;
        }
        $p .= "<p>\n";
    }
    else {
        my $google_pc = "/home/doi/www/cgi-bin/dbinfo/google";
        if ($gtype eq 'none') {
            $google_pc = '';
        }
        elsif ($gtype ne '') {
            my $gp = $google_pc . '-' . $gtype;
            $google_pc = $gp if (-e $gp);
        }
        $p .= "</td><td bgcolor=\"#ffcccc\" width=170>\n";
        $p .= $links;
        $p .= "<p><center>\n";
        if ($google_pc ne '') {
            $p .= "--advertisements--<br>\n";
            $p .= &read_localfile($google_pc);
        }
        $p .= "</center>\n";
        $p .= "</td></tr></table>\n";
    }
    return $p;
}

sub bottom_line
{
    my $type = $_[0];
    my $doilink = '/doi/';
    my $seiyuulink = '/doi/seiyuu/';
    my $rsslink = '/doi/rss2.xml';
    if ($type eq 'smartphone') {
        $doilink = '/doi-bin/Viphone.pl?/';
        $seiyuulink = '/doi-bin/Viphone.pl?/seiyuu/';
    }
    my $p = "<table width=\"100%\" cellspacing=0><tr valign=top>\n";
    $p .= "<td align=center bgcolor=\"#ccffcc\">\n";
    $p .= "<a href=\"$doilink\">Hitoshi Doi</a>";
    $p .= " | <a href=\"$seiyuulink\">Seiyuu Database</a>";
    $p .= " | <a href=\"$rsslink\" style=\"color:orange;\">[RSS 2.0]</a>";
    $p .= "</td></tr></table>\n";
    return $p;
}

#
# google charts routines
#
sub googlecharts_top
{
    my $pk = $_[0];
    $pk = 'line' if ($pk eq '');
    my $gurl = 'https://www.gstatic.com/charts/loader.js';
    my $p = '';
    $p .= '<script type="text/javascript" src="' . $gurl . '">';
    $p .= '</script>' . "\n";
    $p .= '<script type="text/javascript">' . "\n";
    $p .= "google.charts.load('current',{'packages':['$pk']});\n";
    $p .= "</script>\n";
    return $p;
}

sub googlecharts_linechart
{
    my ($id, $options, $data) = @_;
    my $p = '';
    $p .= '<script type="text/javascript" >' . "\n";
    $p .= "google.charts.setOnLoadCallback(drawLinechart$id);\n";
    $p .= "function drawLinechart$id() {\n";
    $p .= "var options = {\n" . $options . "};\n";
    $p .= "var data = google.visualization.arrayToDataTable([\n";
    $p .= $data;
    $p .= "]);\n";
    $p .= "var ele = document.getElementById('$id');\n";
    $p .= "var chart = new google.charts.Line(ele);\n";
    $p .= "chart.draw(data, options);\n";
    $p .= "}\n";
    $p .= "</script>\n";
    return $p;
}

1;

