rectool/trunk/rectool.pl

   1 #!/usr/bin/perl
   2 # -d:SmallProf
   3 #use Perl6::Slurp;
   4 #use XML::Simple;
   5 #use CGI;
   6 #use CGI::Lite;
   7 #use Date::Manip;
   8 #Date_Init("TZ=JST","ConvTZ=JST");
   9 #use SVG;
  10 #use KCatch;
  11 use CGI::Carp qw( fatalsToBrowser );
  12 use DBI;
  13 use Date::Simple;
  14 use DateTime;
  15 use CGI::Minimal;
  16 use MIME::Base64;
  17 use Config::Simple;
  18 use Time::HiRes;
  19 use Data::Dumper;
  20 #require SVG Time::Simple Encode Text::Ngram File::Find Data::Dumper Perl6::Slurp List::Util
  21 #use utf8;
  22 %DB::packages = ( 'main' => 1 );
  23 my $tz = DateTime::TimeZone->new( name => 'local' );
  24 my $hires = Time::HiRes::time();
  25
  26 my $cfg = new Config::Simple;
  27 $cfg->read( 'config.ini' );
  28 my $sql = $cfg->param( 'db.db' );
  29
  30 if ( $sql eq 'SQLite' ) {
  31         $dbh = DBI->connect("dbi:SQLite:dbname=ch.db", undef, undef, {
  32                 AutoCommit => 1,
  33                 RaiseError => 1,
  34         });
  35         $SQL{'SUBSTR'} = 'SUBSTR(start, 0, 9)';
  36 }
  37
  38 if ( $sql eq 'MySQL' ) {
  39         my $name = $cfg->param( 'db.mysql_dbname' );
  40         my $host = $cfg->param( 'db.mysql_host' );
  41         my $port = $cfg->param( 'db.mysql_port' );
  42         my $user = $cfg->param( 'db.mysql_user' );
  43         my $pass = $cfg->param( 'db.mysql_passwd' );
  44         $dbh = DBI->connect("dbi:mysql:$name:$host:$port", $user, $pass, {
  45                 AutoCommit => 1,
  46                 RaiseError => 1,
  47         });
  48         $dbh->do( 'SET NAMES utf8' );
  49         $SQL{'SUBSTR'} = 'SUBSTRING(start, 1, 8)';
  50 }
  51
  52 my $HTML;
  53
  54 #print "Content-Type: text/html\n\n";
  55
  56 $HTTP_HEADER = "Content-Type: text/html\n\n";
  57 $HTML .= <<EOM;
  58 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
  59 <html lang="ja">
  60 <head>
  61 <title>Rec10%HTML_TITLE_OPT%</title>
  62 <meta http-equiv="Content-Script-Type" content="text/javascript">
  63 <meta http-equiv="Content-Style-Type" content="text/css">
  64 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
  65 <link rev="MADE" href="Rea10">
  66 %REFRESH%
  67 %SCRIPT%
  68 %CSS%
  69 </head>
  70 <body>
  71 %HTML_HEADER%
  72 EOM
  73
  74
  75 $q = new CGI::Minimal;
  76 $mode = $q->param( 'mode' );
  77
  78 $display = $q->param( 'ch' );
  79 $start   = $q->param( 'start' );
  80 $stop    = $q->param( 'stop' );
  81 $key     = $q->param( 'key' );
  82 @id      = $q->param( 'id' );
  83
  84 %type = (
  85         'res'         => '一回限定',
  86         'rec'         => '最終段階',
  87         'key'         => '当日検索',
  88         'keyevery'    => '隔日検索',
  89         'tsrecording' => '録画途中',
  90         'tsfin'       => '録画終了',
  91         'tsmiss'      => '録画失敗',
  92         'b252ts'      => '解読予約',
  93         'tsdecoding'  => '解読途中',
  94         'ts2avi'      => '縁故予約',
  95         'local'       => '縁故於鯖',
  96         'grid'        => '縁故於網',
  97         'fin_local'   => '縁故完了',
  98         'end'         => '録画終了',
  99 );
 100
 101 %category = (
 102         'etc'         => 'その他',
 103         'news'        => 'ニュース・報道',
 104         'variety'     => 'バラエティ',
 105         'anime'       => 'アニメ・特撮',
 106         'information' => '情報',
 107         'drama'       => 'ドラマ',
 108         'sports'      => 'スポーツ',
 109         'music'       => '音楽',
 110         'cinema'      => '映画',
 111 );
 112
 113 if ( $mode eq 'schedule' ) {
 114
 115         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer/;
 116 #       $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
 117         $css = <<EOM;
 118                 <style type="text/css">
 119                 td {
 120                         white-space: nowrap;
 121                 }
 122                 </style>
 123 EOM
 124         $css =~ s/^\t{2}//gm;
 125         $HTML =~ s/%CSS%/$css/;
 126
 127         my $order = $q->param( 'order' );
 128         my $extra = $q->param( 'extra' );
 129         if ( $order ne 'id' ) {
 130                 $order = 'btime';
 131         }
 132         $reverse_extra = $extra            ? '' : '&amp;extra=1';
 133         $forward_order = $order eq 'btime' ? '' : '&amp;order=id';
 134
 135         my $ary_ref = $dbh->selectall_arrayref(
 136                 "SELECT id, type, rectime.chtxt, chdata.ontv, ch.display, title, btime, etime, opt, deltaday, deltatime
 137                 FROM rectime
 138                 INNER JOIN chdata ON rectime.chtxt = chdata.chtxt
 139                 INNER JOIN ch     ON chdata.ontv   = ch.channel
 140                 ORDER BY $order");
 141
 142         $HTML .= qq {<div style="font-size: 10pt; float: left">\n};     my $ary_ref = $dbh->selectall_arrayref(
 143                 "SELECT id, type, rectime.chtxt, chdata.ontv, ch.display, title, btime, etime, opt, deltaday, deltatime
 144                 FROM rectime
 145                 INNER JOIN chdata ON rectime.chtxt = chdata.chtxt
 146                 INNER JOIN ch     ON chdata.ontv   = ch.channel
 147                 ORDER BY $order");
 148
 149         $HTML .= qq {<form method="get" action="rectool.pl">\n};
 150         $HTML .= qq {<div>\n};
 151         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 152         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
 153         $HTML .= qq {<th><a href="rectool.pl?mode=schedule$forward_order$reverse_extra">■</a></th>\n};
 154         $HTML .= qq {<th><a href="rectool.pl?mode=schedule&amp;order=id">ID</a></th>\n};
 155         $HTML .= qq {<th>タイプ</th>\n};
 156         $HTML .= qq {<th>チャンネル</th>\n};
 157         $HTML .= qq {<th>タイトル</th>\n};
 158         $HTML .= qq {<th><a href="rectool.pl?mode=schedule">開始時刻</a></th>\n};
 159         $HTML .= qq {<th>終了時刻</th>\n};
 160         $HTML .= qq {<th>録画時間</th>\n};
 161         $HTML .= qq {<th>オプション</th>\n};
 162         $HTML .= qq {<th>dd</th>\n};
 163         $HTML .= qq {<th>dt</th>\n};
 164         $HTML .= qq {</tr>\n};
 165         foreach my $line ( @{ $ary_ref } ) {
 166
 167                 $type = $type{$line->[1]} || $line->[1];
 168                 if    ( $line->[1] eq 'key' || $line->[1] eq 'keyevery' ) {
 169                         $type = qq {<span style="color: #800080">$type</span>};
 170                         $line->[9]  = qq {<span style="color: #FF0000">空</span>} if ( !$line->[9] && $line->[1] eq 'keyevery' );
 171                         $line->[10] = qq {<span style="color: #FF0000">空</span>} if ( !$line->[10] );
 172                 }
 173                 elsif ( $line->[1] eq 'res' || $line->[1] eq 'rec' ) {
 174                         $type = qq {<span style="color: #A0A000">$type</span>};
 175                 }
 176                 elsif ( $line->[1] eq 'tsrecording' ) {
 177                         $type = qq {<span style="color: #FFA000">$type</span>};
 178                 }
 179                 elsif ( $line->[1] eq 'b252ts' || $line->[1] eq 'ts2avi' ) {
 180                         $type = qq {<span style="color: #404040">$type</span>};
 181                 }
 182                 elsif ( $line->[1] eq 'tsdecoding' ) {
 183                         $type = qq {<span style="color: #C04040">$type</span>};
 184                 }
 185                 elsif ( $line->[1] eq 'local' ) {
 186                         $type = qq {<span style="color: #008080">$type</span>};
 187                 }
 188                 else {
 189                         $type = qq {<span style="color: #A0A0A0">$type</span>};
 190                 }
 191                 $display = $q->url_encode( $line->[4] );
 192                 $line->[5] = 'タイトルなし' if ( !$line->[5] );
 193                 my @unix_6 = $line->[6] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 194                 my $unix_6 = DateTime->new(
 195                         year => $unix_6[0], month  => $unix_6[1], day    => $unix_6[2],
 196                         hour => $unix_6[3], minute => $unix_6[4], second => $unix_6[5],
 197                         time_zone => $tz
 198                 );
 199                 my @unix_7 = $line->[7] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 200                 my $unix_7 = DateTime->new(
 201                         year => $unix_7[0], month  => $unix_7[1], day    => $unix_7[2],
 202                         hour => $unix_7[3], minute => $unix_7[4], second => $unix_7[5],
 203                         time_zone => $tz
 204                 );
 205
 206                 my $btime = $unix_6->strftime( '%Y%m%d%H%M%S' );
 207                 my $etime = $unix_7->strftime( '%Y%m%d%H%M%S' );
 208                 if ( $extra and $line->[1] =~ /key|res/ ) {
 209                         my @ary = $dbh->selectrow_array(
 210                                 "SELECT title, exp FROM tv
 211                                 WHERE channel = '$line->[3]'
 212                                 AND start = '$btime'
 213                                 AND stop  = '$etime' ");
 214                         $ary[0] = '説明' if ( $line->[1] eq 'res' );
 215                         if ( $ary[0] ) {
 216                                 $ary[0] =~ s/無料≫//;
 217                                 if ( $line->[1] ne 'res' && $ary[0] ne $line->[5] ) {
 218                                         my $count = $ary[0] =~ s/\Q$line->[5]\E//;
 219                                         if ( !$count ) {
 220                                                 $ary[0] = qq {<span style="color: #FF4000">$ary[0]</span>};
 221                                         }
 222                                 }
 223                                 if ( $ary[1] ) {
 224                                         $line->[11] = qq {<div style="float: right; cursor: help" title="$ary[1]">$ary[0]</div>};
 225                                 }
 226                                 else {
 227                                         # $line->[11] = qq {<span style="float: right; color: #FF0000">該当なし</span>};
 228                                         $line->[11] = qq {<span style="float: right">説明なし</span>};
 229                                 }
 230                         }
 231                         else {
 232                                 my $href    = qq {<a href="rectool.pl?mode=edit&amp;id=$line->[0]&amp;suggest=auto">自動検索</a>};
 233                                 $line->[11] = qq {<span style="float: right; color: #FF0000">！$href！</span>};
 234                         }
 235                 }
 236
 237                 my $begin = $unix_6->strftime( '%m/%d %H:%M' );
 238                 my $end;
 239                 if ( $unix_6->month == $unix_7->month && $unix_6->day == $unix_7->day )
 240                 {
 241                         $end   = $unix_7->strftime( '%H:%M' );
 242                 }
 243                 else {
 244                         $end   = $unix_7->strftime( '翌 %H:%M' );
 245                 }
 246
 247                 my ( $sec, $min, $hour );
 248                 $sec  = $unix_7->epoch - $unix_6->epoch;
 249                 $min  = int( $sec / 60 );
 250                 $sec  = $sec - $min * 60;
 251                 $hour = int( $min / 60 );
 252                 $min  = $min - $hour * 60;
 253                 my $diff = '';
 254                 $diff .= $hour . '時間' if ( $hour );
 255                 $diff .= $min  . '分'   if ( $min );
 256                 $diff .= $sec  . '秒'   if ( $sec );
 257
 258                 my $hr;
 259                 if (
 260                         $line->[1] eq 'tsrecording'
 261                                 &&
 262                         $unix_6->epoch <= time && time <= $unix_7->epoch
 263                 )
 264                 {
 265                         $percent = int( ( 100 * ( time - $unix_6->epoch ) ) / ( $unix_7->epoch - $unix_6->epoch ) );
 266                         $hr .= qq {<hr style="margin: 0 auto 0 0; height: 4px; width: $percent%;};
 267                         $hr .= qq { background-color: blue; border: none" title="$percent%">};
 268                 }
 269
 270                 $line->[5] = qq {<div style="float: left">$line->[5]</div>} if ( $line->[11] );
 271                 $line->[5] = qq {<a href="rectool.pl?mode=edit&amp;id=$line->[0]">$line->[5]</a>};
 272                 $HTML .= qq {<tr align="center">\n};
 273                 $HTML .= qq {<td><input type="checkbox" name="id" value="$line->[0]"></td>\n};
 274                 $HTML .= qq {<td>$line->[0]</td>\n};
 275                 $HTML .= qq {<td>$type</td>\n};
 276                 $HTML .= qq {<td><a href="rectool.pl?mode=program&amp;ch=$display">$line->[2]</a></td>\n};
 277                 $HTML .= qq {<td align="left" style="white-space: normal">$line->[5]$line->[11]</td>\n};
 278                 $HTML .= qq {<td>$begin</td>\n<td>$end</td>\n};
 279                 $HTML .= qq {<td>$hr$diff</td>\n};
 280                 $HTML .= qq {<td>$line->[8]</td>\n<td>$line->[9]</td>\n<td>$line->[10]</td>\n};
 281                 # $HTML .= qq {<td>$line->[11]</td>\n} if ( $extra );
 282                 $HTML .= qq {</tr>\n};
 283         }
 284         $HTML .= qq {</table>\n};
 285         $HTML .= qq {<input type="submit" name="edit" value="編集(要JS)">\n};
 286         $HTML .= qq {<input type="submit" name="delete" value="削除">\n</div>\n</form>\n};
 287         goto end;
 288 }
 289
 290 if ( $mode eq 'graph' ) {
 291
 292         $graph = $q->param( 'graph' );
 293
 294         if ( $graph )
 295         {
 296                 print "Content-Type: image/svg+xml\n\n";
 297
 298                 require SVG;
 299                 $graph = Date::Simple->new( split /-/, $graph );
 300                 $graph_bgn = $graph->format('%Y-%m-%d');
 301                 $graph_end = $graph->next->format('%Y-%m-%d');
 302                 $day = $graph->day;
 303                 $today = $graph eq Date::Simple->today() ? 1 : 0;
 304
 305                 $tuner{terrestrial} = 2; #$cfg->param( 'env.te_max' );
 306                 $tuner{satellite}   = 4; #$cfg->param( 'env.bscs_max' );
 307                 $tuner{all} = $tuner{terrestrial} + $tuner{satellite};
 308                 $hours = 24;
 309                 $width = 30 * $hours;
 310
 311                 $svg = new SVG( width => 820, height => $tuner{all} * 20 + 40 );
 312                 $svg->rectangle( 'x' => 40, 'y' => 20,
 313                         width => $width + 20, height => $tuner{all} * 20 + 10,
 314                         rx => 15, ry => 15,
 315                         style => { stroke => 'blue', fill => 'white' } );
 316                 for ( 1..$tuner{terrestrial} ) {
 317                         $svg->text( 'x' => 10, 'y' => ( $_ + 1 ) * 20 )
 318                                 ->cdata( "T$_" );
 319                 }
 320                 for ( 1..$tuner{satellite} ) {
 321                         $svg->text( 'x' => 10, 'y' => ( $_ + $tuner{terrestrial} + 1 ) * 20 )
 322                                 ->cdata( "S$_" );
 323                 }
 324                 for ( 0..$hours ) {
 325                         $svg->text( 'x' => $_ * 30 + 65, 'y' => 15,
 326                                 style => { 'text-anchor' => 'middle' } )
 327                                 ->cdata( sprintf( '%02d', $_ ) ) if ( $_ < $hours );
 328 #                       $svg->line( ); # can't use when required
 329                         $svg->tag( 'line', x1 => $_ * 30 + 50, x2 => $_ * 30 + 50, y1 => 30, y2 => $tuner{all} * 20 + 20,
 330                                 style => { stroke => 'gray' } );
 331                 }
 332                 for ( 1..$tuner{all} ) {
 333                         $svg->rectangle( 'x' => 50, 'y' => $_ * 20 + 10, width => $width, height => 10 );
 334                 }
 335                 if ( $today ) {
 336                         require Time::Simple;
 337                         my $time = Time::Simple->new();
 338                         my $x = ( $time->hours * 60 + $time->minutes ) * 0.5 + 50;
 339                         $svg->tag( 'line', x1 => $x, x2 => $x, y1 => 30, y2 => $tuner{all} * 20 + 20,
 340                                 style => { stroke => 'red', 'fill-opacity' => '1.0' } );
 341                 }
 342                 foreach my $bctype ( 'te%', '_s%' ) {
 343                         my $tuner = $bctype eq 'te%' ? $tuner{terrestrial} : $tuner{satellite};
 344                         my $ary_ref = $dbh->selectall_arrayref(
 345                                 "SELECT id, type, rectime.chtxt, title, btime, etime, opt FROM rectime
 346                                 INNER JOIN chdata ON rectime.chtxt = chdata.chtxt
 347                                 WHERE chdata.bctype LIKE '$bctype'
 348                                 AND type IN ( 'rec', 'res', 'key', 'keyevery', 'tsrecording' )
 349                                 AND
 350                                 (
 351                                         '$graph_bgn 00:00' <= btime AND btime <  '$graph_end 00:00'
 352                                                 OR
 353                                         '$graph_bgn 00:00' <  etime AND etime <= '$graph_end 00:00'
 354                                 )
 355                                 ORDER BY id"
 356                         );
 357                         foreach my $line ( @{ $ary_ref } ) {
 358                                 @start = $line->[4] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 359                                 @stop  = $line->[5] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 360                                 $start = ( ( $day == $start[2] ? 0 : 24 * 60 ) + $start[3] * 60 + $start[4] ) * 0.5;
 361                                 $stop  = ( ( $day == $stop [2] ? 0 : 24 * 60 ) + $stop [3] * 60 + $stop [4] ) * 0.5;
 362                                 $start = 0      if ( $start < 0 || $day > $start[2] ); # 月の変わり目はスルー
 363                                 $stop  = $width if ( $stop  > $width );
 364                                 $begin = $line->[4];
 365                                 $end   = $line->[5];
 366
 367                                 my $ary = $dbh->selectall_arrayref(
 368                                         "SELECT id, type, rectime.chtxt, title, btime, etime, opt FROM rectime
 369                                         INNER JOIN chdata ON rectime.chtxt = chdata.chtxt
 370                                         WHERE chdata.bctype LIKE '$bctype'
 371                                         AND type IN ( 'rec', 'res', 'key', 'keyevery', 'tsrecording' )
 372                                         AND NOT
 373                                         (
 374                                                 ( etime <= '$begin' )
 375                                                         OR
 376                                                 ( btime >= '$end'   )
 377                                         )
 378                                         ORDER BY id"
 379                                 );
 380                                 my @ary = @{$ary};
 381                                 for ( 0..$tuner - 1 ) {
 382                                         $f = 1;
 383                                         $i = $_;
 384                                         for ( 0..4 ) {
 385                                                 $f = 0 if ( $line->[$_] ne $ary[$i]->[$_] );
 386                                         }
 387                                         if ( $f ) {
 388                                                 $slot = $i;
 389                                         }
 390                                 }
 391                                 my ( $r, $g, $b ) = ( 0, 0, 0 );
 392                                 $r += 255 if ( $line->[6] =~ /a/ );
 393                                 $g += 255 if ( $line->[6] =~ /H/ );
 394                                 $b += 255 if ( $line->[6] =~ /2/ );
 395                                 if ( $r + $g + $b == 255 * 3 ){
 396                                         $r = 0;
 397                                         $g = 255;
 398                                         $b = 255;
 399                                 }
 400                                 if ( $r + $g + $b == 0 ){
 401                                         $r = $g = $b = 128;
 402                                 }
 403                                 my %escaped = ( '&' => 'amp', '<' => 'lt', '>' => 'gt', '"' => 'quot' );
 404                                 sub html_escape{
 405                                     my $str = shift or return;
 406                                     my $result = '';
 407                                     $result .= $escaped{$_} ? '&' . $escaped{$_} . ';' : $_
 408                                         for (split //, $str);
 409                                     $result;
 410                                 }
 411                                 $svg->anchor(
 412                                         -href  => "rectool.pl?mode=edit&amp;id=$line->[0]",
 413                                         target => '_blank',
 414                                         -title => html_escape( $line->[3] ),
 415                                 )->rectangle(
 416                                         'x' => 50 + $start,
 417                                         'y' => 30 + ( $bctype eq 'te%' ? 0 : $tuner{terrestrial} * 20 ) + $slot * 20,
 418                                         width  => $stop - $start,
 419                                         height => 10,
 420                                         style  => { fill => "rgb($r,$g,$b)" } );
 421                         }
 422                 }
 423                 print $svg->xmlify;
 424                 exit;
 425         }
 426         else
 427         {
 428                 $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer - Graphical/;
 429                 $HTML .= qq {<div style="float: left">\n};
 430 #               $base64 = encode_base64( $svg->xmlify );
 431 #               $HTML .= qq {<object data="data:image/svg+xml;base64,$base64">\n</object>\n};
 432                 $HTML .= qq {予約状況一覧です。T1,T2は地上波、S1,S2はBS/CS、赤はアニメ、緑はHD、青は2 passを示しています。<br>\n};
 433                 $HTML .= qq {SVGが利用可能なブラウザでご覧ください。<br>\n};
 434
 435                 $ary_ref = $dbh->selectcol_arrayref(
 436 #                       "SELECT DISTINCT SUBSTR( btime, 0, 11 )
 437                         "SELECT DISTINCT DATE( btime )
 438                         FROM rectime
 439                         WHERE type in ( 'rec', 'res', 'key', 'keyevery', 'tsrecording' )
 440                         ORDER BY btime"
 441                 );
 442                 foreach my $date ( @{ $ary_ref } ) {
 443                         my @date = $date =~ /(.{4})-(.{2})-(.{2})/;
 444                         my $dn = DateTime->new( year => $date[0], month => $date[1], day => $date[2], locale => 'ja_JP' )->day_name;
 445                         utf8::encode( $dn );
 446                         $HTML .= qq {$date[1]/$date[2]($dn)の予約状況<br>\n};
 447                         $HTML .= qq {<object type="image/svg+xml" data="rectool.pl?mode=graph&amp;graph=$date" width="820">\n};
 448                         # width=821 height=121>\n};
 449                         $HTML .= qq {SVG Image $date\n</object>\n<br>\n};
 450
 451                         $date2 = Date::Simple->new( @date )->next->format('%Y-%m-%d');
 452                         my $ary_ref = $dbh->selectall_arrayref(
 453                                 "SELECT chtxt, title, btime, etime FROM rectime
 454                                 WHERE '$date 00:00' <= btime AND etime <= '$date2 01:00'
 455                                 ORDER BY btime"
 456                         );
 457
 458                         foreach my $line ( @{ $ary_ref } ) {
 459 #                               $HTML .= qq {$line->[0] $line->[1] $line->[2] $line->[3]<br>\n};
 460                         }
 461
 462                 }
 463
 464                 goto end;
 465         }
 466 }
 467
 468 if ( $mode eq 'edit' ) {
 469         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Editor/;
 470         $HTML .= qq {<div style="float: left">\n};
 471
 472         $script = <<EOM;
 473                 <script type="text/javascript" src="http://www.enjoyxstudy.com/javascript/dateformat/dateformat.js">
 474                 </script>
 475                 <script type="text/javascript">
 476                 function setType(value){
 477                         var index = document.reserve.type.selectedIndex;
 478                         var value = document.reserve.type[index].value;
 479                         if ( value == 'keyevery' ) {
 480                                 document.reserve.deltaday.value  = 7;
 481                                 document.reserve.deltatime.value = 3;
 482                         }
 483                         if ( value == 'ts2avi' || value == 'b252ts' ){
 484                                 var date       = new Date();
 485                                 var dateFormat = new DateFormat("yyyy-MM-dd HH:mm:ss");
 486                                 var minutes    = date.getMinutes();
 487                                 minutes = minutes - minutes % 5 + 10;
 488                                 date.setMinutes(minutes, 0, 0);
 489                                 document.reserve.begin.value = dateFormat.format(date);
 490                                 date.setSeconds( date.getSeconds() + 3600 );
 491                                 document.reserve.end.value   = dateFormat.format(date);
 492                         }
 493                 }
 494                 function setSuggest(start, stop){
 495                         document.reserve.begin.value = start;
 496                         document.reserve.end.value   = stop;
 497                 }
 498                 </script>
 499 EOM
 500         $script =~ s/^\t{2}//gm;
 501         $HTML =~ s/%SCRIPT%/$script/;
 502
 503         $HTML .= "スケジュール編集画面です。<br>\n";
 504         $HTML .= "実装がとても適当なので、利用には細心の注意を払ってください。<br>\n<br>\n";
 505         if ( $id[0] ) {
 506                 @reserve = $dbh->selectrow_array(
 507                         "SELECT id, type, chtxt, title, btime, etime, deltaday, deltatime, opt
 508                         FROM rectime
 509                         WHERE id = $id[0]"
 510                 );
 511                 $button_bgn = $button_end = '';
 512         }
 513         else {
 514                 $reserve[1] = 'res';
 515                 $datetime_now = DateTime->now( time_zone => $tz )->set_second( 0 )->strftime( '%Y-%m-%d %H:%M:%S' );
 516                 $button_bgn = qq{<button type="button" onClick="document.reserve.begin.value='$datetime_now'">現在</button>\n<br>\n};
 517                 $button_end = qq{<button type="button" onClick="document.reserve.end.value=document.reserve.begin.value">一致</button>};
 518         }
 519
 520         if ( $q->param( 'suggest' ) eq 'auto' ) {
 521                 require Encode;
 522                 require Text::Ngram;
 523
 524                 my @btime = $reserve[4] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 525                 my @etime = $reserve[5] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 526                 my $btime = DateTime->new(
 527                         year => $btime[0], month  => $btime[1], day    => $btime[2],
 528                         hour => $btime[3], minute => $btime[4], second => $btime[5],
 529                 );
 530                 my $etime = DateTime->new(
 531                         year => $etime[0], month  => $etime[1], day    => $etime[2],
 532                         hour => $etime[3], minute => $etime[4], second => $etime[5],
 533                 );
 534                 $btime_bgn = $btime->clone;
 535                 $btime_end = $btime->clone;
 536                 $etime_bgn = $etime->clone;
 537                 $etime_end = $etime->clone;
 538                 $btime_bgn->subtract( hours => $reserve[7] );
 539                 $btime_end->add(      hours => $reserve[7] );
 540                 $etime_bgn->subtract( hours => $reserve[7] );
 541                 $etime_end->add(      hours => $reserve[7] );
 542                 $btime_bgn = $btime_bgn->strftime( '%Y%m%d%H%M%S' );
 543                 $btime_end = $btime_end->strftime( '%Y%m%d%H%M%S' );
 544                 $etime_bgn = $etime_bgn->strftime( '%Y%m%d%H%M%S' );
 545                 $etime_end = $etime_end->strftime( '%Y%m%d%H%M%S' );
 546
 547                 my $ontv = $dbh->selectrow_array( "SELECT ontv FROM chdata WHERE chtxt = '$reserve[2]' " );
 548                 $ary_ref = $dbh->selectall_arrayref(
 549                         "SELECT start, stop, title, exp
 550                         FROM tv
 551                         WHERE channel = '$ontv'
 552                         AND start BETWEEN '$btime_bgn' AND '$btime_end'
 553                         AND stop  BETWEEN '$etime_bgn' AND '$etime_end' "
 554                 );
 555
 556                 my %hash;
 557                 my $hash_r = Text::Ngram::ngram_counts( Encode::decode_utf8( $reserve[3] ), 2 ); # bi-gram
 558                 foreach my $program ( @{$ary_ref} ) {
 559                         my $hash_k = Text::Ngram::ngram_counts( Encode::decode_utf8( $program->[2] ), 2 );
 560                         my $point;
 561                         map $point += $hash_k->{$_}, keys %{$hash_r};
 562                         push @{$hash{$point}}, $program if ( $point );
 563                 }
 564
 565                 $HTML .= qq {可能性のある番組<br>\n};
 566                 $HTML .= qq {<table summary="suggesttable" border=1 cellspacing=0>\n<tr>\n};
 567                 $HTML .= qq {<th>優先度</th>\n};
 568                 $HTML .= qq {<th>タイトル</th>\n};
 569                 $HTML .= qq {<th>開始時刻</th>\n};
 570                 $HTML .= qq {<th>終了時刻</th>\n};
 571                 $HTML .= qq {<th>説明</th>\n};
 572                 $HTML .= qq {<th>適用</th>\n};
 573                 $HTML .= qq {</tr>\n};
 574
 575                 foreach my $key (sort keys %hash){
 576                         my $val = $hash{$key};
 577                         foreach my $val ( @{$val} ) {
 578                                 my $style = qq {style="white-space: nowrap"};
 579                                 $val->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 580                                 $val->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 581                                 $HTML .= qq {<tr>\n<td>$key</td>\n<td>$val->[2]</td>\n};
 582                                 $HTML .= qq {<td $style>$val->[0]</td>\n<td $style>$val->[1]</td>\n<td>$val->[3]</td>\n};
 583                                 $HTML .= qq {<td><button onClick="setSuggest('$val->[0]','$val->[1]');">適用</button></td>\n</tr>\n};
 584                         }
 585                 }
 586                 $HTML .= qq {</table>\n<br>\n};
 587         }
 588
 589         my $len = length $reserve[0];
 590         $HTML .= qq {<form method="get" action="rectool.pl" name="reserve">\n};
 591         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 592         $HTML .= qq {<input type="hidden" name="id" value="$reserve[0]">\n};
 593         $HTML .= qq {ID\n<input type="text" name="id" value="$reserve[0]" size=$len disabled>\n};
 594         $HTML .= qq {タイプ\n<select name="type" onChange="setType();">\n};
 595         while ( my ($key, $value) = each %type ) {
 596                 next if ( $key !~ /^rec|res|key|ts2avi|b252ts|$reserve[1]/ );
 597                 if ( $key eq $reserve[1] ) {
 598                         $HTML .= qq {<option value="$key" selected>$value</option>\n};
 599                 }
 600                 else {
 601                         $HTML .= qq {<option value="$key">$value</option>\n};
 602                 }
 603         }
 604         $HTML .= qq {</select>\n};
 605         $HTML .= qq {チャンネル\n<select name="ch">\n};
 606         $ary_ref = $dbh->selectall_arrayref(
 607                 "SELECT display, chtxt FROM ch INNER JOIN chdata ON ch.channel = chdata.ontv"
 608         );
 609         foreach my $ch ( @{$ary_ref} ) {
 610                 if ( $ch->[1] eq $reserve[2] ) {
 611                         $HTML .= qq {<option value="$ch->[1]" selected>$ch->[0]</option>\n};
 612                 }
 613                 else {
 614                         $HTML .= qq {<option value="$ch->[1]">$ch->[0]</option>\n};
 615                 }
 616         }
 617         $HTML .= qq {</select><br>\n};
 618         $HTML .= qq {タイトル\n<input type="text" name="title"     value="$reserve[3]" size=64><br>\n};
 619         $HTML .= qq {開始時刻\n<input type="text" name="begin"     value="$reserve[4]" maxlength=19 size=24>\n}.$button_bgn;
 620         $HTML .= qq {終了時刻\n<input type="text" name="end"       value="$reserve[5]" maxlength=19 size=24>\n}.$button_end."<br>\n";
 621         $HTML .= qq {隔日周期\n<input type="text" name="deltaday"  value="$reserve[6]" maxlength=2  size=2>\n};
 622         $HTML .= qq {時刻誤差\n<input type="text" name="deltatime" value="$reserve[7]" maxlength=2  size=2>\n};
 623         $HTML .= qq {オプション\n<input type="text" name="opt"     value="$reserve[8]">\n};
 624         $HTML .= qq {<input type="submit" name="update" value="更新">\n</form>\n};
 625 }
 626
 627 if ( $mode eq 'change' ) {
 628         $HTML =~ s/%HTML_TITLE_OPT%/ - Change/;
 629         $HTML .= qq {<div style="float: left">\n};
 630
 631         if ( $q->param( 'delete' ) )
 632         {
 633                 if ( @id ) {
 634                         foreach my $id ( @id ) {
 635                                 $dbh->do( "DELETE FROM rectime WHERE id = '$id'" );
 636                         }
 637                         $HTML .= "削除しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 638                         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 639                         goto end;
 640                 }
 641         }
 642         if ( $q->param( 'edit' ) )
 643         {
 644                 if ( $q->param( 'edit' ) eq '編集(要JS)' ) {
 645                         $HTML .= "スケジュール編集画面に移動します。<br>\n";
 646                         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="0; url=../rec10web/rec10web.py?exec=edit:$id[0]">|;
 647                         goto end;
 648                 }
 649                 else {
 650                         goto end;
 651                 }
 652         }
 653         if ( $q->param( 'update' ) )
 654         {
 655                 $type      = $q->param( 'type' );
 656                 $chtxt     = $q->param( 'ch' );
 657                 $title     = $q->param( 'title' );
 658                 $begin     = $q->param( 'begin' );
 659                 $end       = $q->param( 'end' );
 660                 $deltaday  = $q->param( 'deltaday' );
 661                 $deltatime = $q->param( 'deltatime' );
 662                 $opt       = $q->param( 'opt' );
 663                 $id        = $id[0];
 664                 if ( $id[0] ) {
 665                         $dbh->do(
 666                                 "UPDATE rectime SET type = '$type', chtxt = '$chtxt', title = '$title',
 667                                 btime = '$begin', etime = '$end',
 668                                 deltaday = '$deltaday', deltatime = '$deltatime', opt = '$opt'
 669                                 WHERE id = '$id'"
 670                         );
 671                 }
 672                 else {
 673                         $dbh->do(
 674                                 "INSERT INTO rectime ( type, chtxt, title, btime, etime, deltaday, deltatime, opt )
 675                                 VALUES ( '$type', '$chtxt', '$title', '$begin', '$end', '$deltaday', '$deltatime', '$opt' )"
 676                         );
 677                 }
 678                 $HTML .= "更新しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 679                 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 680                 goto end;
 681         }
 682 }
 683
 684 if ( $mode eq 'confirm' ) {
 685         # && $display && $start && $stop
 686
 687         $HTML =~ s/%HTML_TITLE_OPT%/ - Reserver/;
 688         $HTML .= qq {<div style="float: left">\n};
 689         &parse_program();
 690
 691         my $duration = ( str2datetime( $end ) - str2datetime( $begin ) )->delta_minutes;
 692         $HTML .= "番組名：$title<br>\nチャンネル：$display<br>\n放送継続時間：$duration分<br>\n";
 693         if ( &check_error() )
 694         {
 695                 # エラー
 696
 697                 $ary_ref = $dbh->selectall_arrayref(
 698                         "SELECT start, stop FROM tv WHERE channel = '$channel' AND title = '$title' "
 699                 );
 700                 $HTML .= "同一の番組の他の放送予定です。<br>\n";
 701                 foreach my $line ( @{$ary_ref} ) {
 702                         $begin = $line->[0];
 703                         $end   = $line->[1];
 704                         $begin =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 705                         $end   =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 706                         $overlap = &get_overlap() >= 2 ? '不可能' :
 707                                 qq {<a href="rectool.pl?mode=confirm&amp;ch=$display} .
 708                                 qq {&amp;start=$line->[0]&amp;stop=$line->[1]">可能</a>};
 709                         $HTML .= "開始：$begin\n終了：$end\n録画は$overlap<br>\n";
 710                 }
 711         }
 712         else {
 713                 $desc = $dbh->selectrow_array(
 714                         "SELECT exp FROM tv WHERE channel = '$channel' AND start = '$start' AND stop = '$stop' "
 715                 );
 716                 $selected_hd   = $chtxt =~ /movieplus/ ? 'selected' : '';
 717                 $selected_full = $chtxt =~ /\Qbs-nhk-hi\E/ ? 'selected' : '';
 718                 $checked_anime = $chtxt =~ /animax|atx|disney|kids/ ? 'checked' : '';
 719                 $checked_dual  = $title =~ /\Q[二]\E|［二］|\Q(二)\E|（二）/ ? 'checked' : '';
 720                 $checked_5_1   = $title =~ /5\.1|5．1/ ? 'checked' : '';
 721
 722                 $HTML .= "番組内容：$desc<br>\n<br>\n録画予約の詳細設定を行ってください。<br>\n";
 723                 $HTML .= qq {<form method="get" action="rectool.pl">\n};
 724                 $HTML .= qq {<input type="hidden" name="mode"  value="reserve">\n};
 725                 $HTML .= qq {<input type="hidden" name="ch"    value="$display">\n};
 726                 $HTML .= qq {<input type="hidden" name="start" value="$start">\n};
 727                 $HTML .= qq {<input type="hidden" name="stop"  value="$stop">\n};
 728                 $HTML .= qq {<select name="opt">\n};
 729                 # $HTML .= qq {<option value="T">TE HD画質(1440x1080)</option>\n};
 730                 # $HTML .= qq {<option value="F" $check>FULLHD画質(1920x1080)</option>\n};
 731                 # $HTML .= qq {<option value="Q">WQVGA画質(400x240)</option>\n};
 732                 $HTML .= qq {<option value="L">L ***x*** 1250kbps</option>\n};
 733                 $HTML .= qq {<option value="G">G 1280x720 2500kbps</option>\n};
 734                 $HTML .= qq {<option value="H" $selected_hd>H 1280x720 3750kbps</option>\n};
 735                 $HTML .= qq {<option value="F" $selected_full>F 1920x1080 5000kbps</option>\n};
 736                 $HTML .= qq {<option value="S">S 720x480 1250kbps</option>\n};
 737                 $HTML .= qq {</select>\n};
 738                 $HTML .= qq {<input type="checkbox" name="opt" value="a" $checked_anime>アニメ\n};
 739                 $HTML .= qq {<input type="checkbox" name="opt" value="d" $checked_dual>二ヶ国語放送\n};
 740                 $HTML .= qq {<input type="checkbox" name="opt" value="2" checked>2passモード\n};
 741                 $HTML .= qq {<input type="checkbox" name="opt" value="5" $checked_5_1>5.1ch放送\n};
 742                 $HTML .= qq {<input type="checkbox" name="opt" value="x">Xvidモード\n};
 743                 $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
 744         }
 745         goto end;
 746 }
 747
 748 if ( $mode eq 'reserve' ) {
 749         $HTML .= qq {<div style="float: left">\n};
 750         &parse_program();
 751         @opt = $q->param( 'opt' );
 752         $opt = join '', @opt;
 753         if ( !&check_error ) {
 754                 $dbh->do(
 755                         "INSERT INTO rectime ( type, chtxt, title, btime, etime, opt )
 756                         VALUES ( 'res', '$chtxt', '$title', '$begin', '$end', '$opt' )"
 757                 );
 758         }
 759         $HTML .= "録画予約を実行しました。<br>\n5秒後にトップへ移動します。<br>\n";
 760         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl">|;
 761         goto end;
 762 }
 763
 764 if ( $mode eq 'program' ) {
 765         &draw_form();
 766
 767         $HTML =~ s/%HTML_TITLE_OPT%/ - Program Viewer/;
 768         $unix = DateTime->now( time_zone => $tz )->strftime( '%Y%m%d%H%M%S' );
 769         $sql =
 770                 "SELECT tv.channel,
 771                         (SELECT display FROM ch WHERE ch.channel = tv.channel),
 772                 start, stop, title, category
 773                 FROM tv
 774                 INNER JOIN chdata ON tv.channel = chdata.ontv
 775                 WHERE $unix <= stop %CH% %DATE% %CATEGORY% %KEY% ORDER BY start";
 776 #               INNER JOIN ch     ON tv.channel = ch.channel
 777
 778         if ( $channel ) {
 779                 my $ch = "AND tv.channel = '$channel'";
 780                 $sql =~ s/%CH%/$ch/;
 781         }
 782         if ( $date_sel ) {
 783                 $date_1 = $date_sel . '000000';
 784                 $date_2 = Date::Simple->new( $date_sel =~ /(.{4})(.{2})(.{2})/ )->next->format('%Y%m%d') . '000000';
 785                 my $date = "AND '$date_1' <= stop AND start <= '$date_2'";
 786                 $sql =~ s/%DATE%/$date/;
 787         }
 788         if ( $category_sel ) {
 789                 # 一時的
 790                         $category_tmp = $category{$category_sel} . $category_sel;
 791                 my $category = "AND category = '$category_tmp'";
 792                 $sql =~ s/%CATEGORY%/$category/;
 793         }
 794         if ( $key ) {
 795                 my $key = "AND TITLE LIKE '%$key%'";
 796                 $sql =~ s/%KEY%/$key/;
 797         }
 798         $sql =~ s/%CH%//;
 799         $sql =~ s/%DATE%//;
 800         $sql =~ s/%KEY%//;
 801         $sql =~ s/%CATEGORY%//;
 802
 803         $ary_ref = $dbh->selectall_arrayref( $sql );
 804         foreach my $prg ( @{ $ary_ref } ) {
 805                 my @date = $prg->[2] =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
 806
 807                 $date = $date[2];
 808                 if ( $date != $prev ) {
 809                         my $date = DateTime->new(
 810                                 year => $date[0], month  => $date[1], day    => $date[2],
 811 #                               hour => $date[3], minute => $date[4], second => $date[5],
 812                                 locale => 'ja_JP'
 813                         );
 814
 815                         my $dn = $date->day_name;
 816                         utf8::encode( $dn );
 817                         $HTML .= qq {--------$date[1]/$date[2]($dn)--------<br>\n};
 818                 }
 819                 $prg->[1] = $q->url_encode( $prg->[1] );
 820                 $HTML .= qq {$date[1]/$date[2] $date[3]:$date[4] };
 821                 $HTML .= qq {<a href="rectool.pl?mode=confirm&amp;ch=$prg->[1]};
 822                 $HTML .= qq {&amp;start=$prg->[2]&amp;stop=$prg->[3]">$prg->[4]</a><br>\n};
 823                 $prev = $date;
 824         }
 825
 826 }
 827
 828 if ( $mode eq 'list' ) {
 829         require File::Find;
 830
 831         $HTML =~ s/%HTML_TITLE_OPT%/ - List/;
 832
 833         my $type = $q->param( 'type' );
 834         my $recording = $cfg->param( 'path.recpath' );
 835         my $recorded  = $cfg->param( 'path.recorded' );
 836
 837         if ( !$type ) {
 838                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;type=new">録画中のみ</a>\n};
 839                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;type=old">録画後のみ</a>\n<br>\n};
 840         }
 841         if ( !$type || $type eq 'new' ) {
 842                 $HTML .= "録画中のファイル一覧<br>\n";
 843                 &list( $recording );
 844         }
 845         if ( !$type ) {
 846                 $HTML .= "<br>\n";
 847         }
 848         if ( !$type || $type eq 'old' ) {
 849                 $HTML .= "録画後のファイル一覧<br>\n";
 850                 &simple_list( $recorded );
 851         }
 852
 853         sub list {
 854                 local $path = shift;
 855                 local %list = ();
 856                 my @exp = ( 'log', 'ts.b25', 'ts.tsmix', 'ts', 'ts.log',
 857                         'sa.avi', 'sa.avi.log', 'm2v', 'wav', 'avi', 'mkv' );
 858                 for ( 0..$#exp ) {
 859                         $exp{$exp[$_]} = $_;
 860                 }
 861                 my $exp_count = scalar keys %exp;
 862
 863                 File::Find::find( \&wanted, $path );
 864
 865                 foreach my $name ( sort { $exp{$a} <=> $exp{$b} } keys %exp ) {
 866                         $HTML .= $exp{$name} + 1 . " = $name / ";
 867                 }
 868                 $HTML .= $exp_count+1 . qq { = サムネイル<br>\n○ = 完了 / ● = 書き込み中<br>\n};
 869                 $HTML .= qq {<table summary="listtable" border=1 cellspacing=0>\n<tr>\n};
 870                 $HTML .= qq {<th>タイトル</th>\n};
 871                 $HTML .= qq {<th>$_</th>\n} for ( 1..$exp_count + 1 );
 872                 $HTML .= qq {<th colspan="2">自動移動</th>\n};
 873                 $HTML .= qq {</tr>\n};
 874
 875                 foreach ( sort keys %list ) {
 876                         my $value = $list{$_};
 877                         my @flag = ( 0 ) x $exp_count;
 878                         $HTML .= qq {<tr>\n<td width="600" style="width: 600px; white-space: normal">$_</td>\n};
 879                         foreach ( keys %{$value} ) {
 880                                 my $tmp = $_;
 881                                 $flag[$exp{$tmp}] = $value->{$_};
 882                         }
 883                         foreach ( @flag ) {
 884                                 my $size = $_->{size};
 885                                 my $last = $_->{last} || '○';
 886                                 my $check = $size ? qq {<span title="$size">$last</span>} : '<br>';
 887                                 $HTML .= qq {<td>$check</td>\n};
 888                         }
 889                         if ( $flag[$exp{mkv}] ) {
 890                                 s/#/＃/g;
 891                                 s/ /\+/g;
 892                                 my $img = $value->{mkv}->{img};
 893                                 $HTML  .= qq {<td><a href="rectool.pl?mode=thumb&amp;title=$img">■</a></td>\n};
 894                                 my $pre = qq {<a href="rectool.pl?mode=move&amp;type=predict&amp;title=$_">予測</a>};
 895                                 $HTML  .= qq {<td>$pre</td>\n};
 896 #                               my $exe = qq {<a href="rectool.pl?mode=move&amp;type=exec&amp;title=$_">実行</a>};
 897                                 my $exe = qq {実行};
 898                                 $HTML  .= qq {<td>$exe</td>\n};
 899                         }
 900                         else {
 901                                 $HTML .= qq {<td><br></td>\n<td colspan="2"><br></td>\n};
 902                         }
 903                         $HTML .= qq {</tr>\n};
 904                 }
 905                 $HTML .= qq {</table>\n};
 906
 907                 sub wanted {
 908                         return if ( !$_ );
 909                         return if ( -d $File::Find::name );
 910                         return if ( $_ eq 'Thumbs.db' );
 911                         return if ( /\.idx/ );
 912                         s/\.temp$//;
 913                         my $regexp = join '|', keys %exp;
 914                         my ( $title, $exp ) = /(.*?)\.($regexp)$/;
 915                         my ( $size, $last ) = &get_size( $File::Find::name );
 916                         my $img;
 917                         $File::Find::name =~ s/\.temp$//;
 918                         if ( $title !~ /[^0-9A-F]/ ) {
 919                                 $title = pack( 'H*', $title );
 920                                 $title = 'Base16_'.$title;
 921                         }
 922                         if ( $_ =~ /mkv/ ) {
 923                                 my $tmp = $title;
 924                                 $tmp =~ s/#/＃/g;
 925                                 $tmp =~ s/ /\+/g;
 926                                 $img = $tmp;
 927 #                               $img = qq {<img width=160 height=120 src="rectool.pl?mode=thumb&amp;title=$tmp"><br>\n};
 928                         }
 929                         die $_ if ( !$title );
 930                         $list{$title}->{$exp} = { 'last' => $last, 'size' => $size, 'img' => $img };
 931                 }
 932         }
 933
 934         sub simple_list {
 935                 local $path = shift;
 936                 local @list = ();
 937
 938                 File::Find::find( \&simple_wanted, $path );
 939
 940                 @list = sort @list;
 941                 foreach ( @list ) {
 942                         $HTML .= "$_<br>\n";
 943                 }
 944
 945                 sub simple_wanted {
 946                         return if ( !$_ );
 947                         return if ( -d $File::Find::name );
 948                         return if ( $_ eq 'Thumbs.db' );
 949                         my ( $size ) = &get_size( $File::Find::name );
 950                         $File::Find::name =~ s/\Q$path\E//;
 951                         push @list, $File::Find::name ."\t\t". $size;
 952                 }
 953         }
 954
 955         sub get_size {
 956                 my $file = shift;
 957                 my ( $size, $last ) = (stat( $file ))[7,9];
 958                 my @unim = ("B","KB","MB","GB","TB","PB");
 959                 my $count = 0;
 960
 961                 while($size >= 1024 ){
 962                         $count++;
 963                         $size = $size / 1024;
 964                 }
 965                 $size *= 100;
 966                 $size  = int( $size );
 967                 $size /= 100;
 968                 if ( time - $last < 10 ) {
 969                         $last = '●';
 970                 }
 971                 else {
 972                         $last = '';
 973                 }
 974                 return ( "$size $unim[$count]", $last );
 975         }
 976 }
 977
 978 if ( $mode eq 'move' ) {
 979         my $type  = $q->param( 'type' );
 980         my $title = $q->param( 'title' );
 981         $title =~ s/＃/#/g;
 982         $title =~ s/\+/ /g;
 983
 984         if ( $type eq 'predict' ) {
 985                 eval '$HTML .= `python26 ' . $cfg->param( 'path.rec10' ) . "classify.py -s '$title'`";
 986         }
 987         elsif ( $type eq 'exec' ) {
 988                 eval '$HTML .= `python26 ' . $cfg->param( 'path.rec10' ) . "classify.py -e '$title'`";
 989         }
 990 }
 991
 992 if ( $mode eq 'thumb' ) {
 993         my $title = $q->param( 'title' );
 994         my $pos  = $q->param( 'pos' );
 995         my $recording = $cfg->param( 'path.recpath' );
 996         $title =~ s/\+/ /g;
 997         $title =~ s/＃/#/g;
 998
 999         print "Content-Type: image/jpeg\n\n";
1000         exec "ffmpeg -ss 300 -i '$recording/$title.mkv' -f image2 -pix_fmt jpg -vframes 1 -s 320x240 -";
1001         exit;
1002 }
1003
1004 if ( $mode eq 'check' ) {
1005 }
1006
1007 if ( $mode eq 'expert' ) {
1008         my $ary_ref;
1009         my $type = $q->param( 'type' );
1010         $HTML =~ s/%HTML_TITLE_OPT%/ - Expert/;
1011         $HTML .= qq {<div>\n};
1012
1013         if ( $type eq 'reget' ) {
1014                 my $display = $q->param( 'ch' );
1015                 my $SQL_WHERE;
1016                 if ( $display =~ /^bs$|^cs.$/ ) {
1017                         $SQL_WHERE = "chdata.bctype = '$display'";
1018                 }
1019                 else {
1020                         $SQL_WHERE = "display = '$display'";
1021                 }
1022                 my $ontv = $dbh->selectrow_array(
1023                         "SELECT ontv FROM ch
1024                         INNER JOIN chdata ON ch.channel = chdata.ontv
1025                         WHERE $SQL_WHERE " );
1026                 $dbh->do( "UPDATE chdata SET status = '2' WHERE ontv = '$ontv' " );
1027                 goto end;
1028         }
1029
1030
1031         $ary_ref = $dbh->selectcol_arrayref(
1032                 "SELECT DISTINCT category FROM tv"
1033         );
1034         # 一時的
1035                 my @category = map { $category{$_} . $_ } sort keys %category;
1036         # my @category = sort keys %category;
1037         $HTML .= qq {<hr>\n番組表のカテゴリ一覧と内蔵の一覧の合致を確認中...\n};
1038         # $HTML .= qq {番組表：@{$ary_ref}<br>\n内蔵：@category<br>\n};
1039         if ( List::Compare->new( $ary_ref, \@category )->get_symdiff ) {
1040                 $HTML .= qq {一致しません<br>\n};
1041         }
1042         else {
1043                 $HTML .= qq {一致しました<br>\n};
1044         }
1045
1046         my @ary = $dbh->selectrow_array( "SELECT terec, bscsrec, b252ts, ts2avi FROM status" );
1047         $HTML .= qq {<hr>\n地上波録画数：$ary[0]\n衛星波録画数：$ary[1]\n解読数：$ary[2]\n縁故数：$ary[3]\n<br>\n};
1048
1049         use List::Compare;
1050         $ary_ref = $dbh->selectall_arrayref( "SELECT display, channel FROM ch INNER JOIN chdata ON ch.channel = chdata.ontv" );
1051         my $prev;
1052         $HTML .= "<hr>\n番組表の欠落<br>\n";
1053         foreach my $line ( @{$ary_ref} ) {
1054                 my $ary_ref = $dbh->selectall_arrayref( "SELECT start, stop, title FROM tv WHERE channel = '$line->[1]' ORDER BY start" );
1055                 my $error;
1056                 my @program_old = ( '', $ary_ref->[0]->[0] );
1057                 my $program_old = \@program_old;
1058
1059                 foreach my $program_new ( @{$ary_ref} ) {
1060                         if ( $program_old->[1] ne $program_new->[0] &&
1061                                 $program_old->[2] !~ /クロ−ジング|クロージング|エンディング|休止|ミッドナイトプレゼント/ &&
1062                                 $program_new->[2] !~ /オープニング|ウィークリー・インフォメーション|モーニングプレゼント/ &&
1063                                 ( str2datetime( $program_new->[0], 1 ) - str2datetime( $program_old->[1], 1 ) )->delta_minutes > 30 ) {
1064                                 $program_old->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1065                                 $program_new->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1066                                 $error .= qq{    $program_old->[2]    $program_old->[1]\n    〜  $program_new->[2]    $program_new->[0]\n};
1067                         }
1068                         $program_old = $program_new;
1069                 }
1070                 $HTML .= qq {<pre>\n$line->[0]\n$error</pre>\n} if ( $error );
1071                 }
1072
1073         $ary_ref = $dbh->selectall_arrayref(
1074                 "SELECT display, chtxt, ontv, chdata.bctype, ch, csch, updatetime, status FROM chdata
1075                 INNER JOIN ch ON ch.channel = chdata.ontv
1076                 ORDER BY bctype " );
1077         $HTML .= qq {<hr>\n番組表の更新状況<br>\n};
1078         $HTML .= qq {<table summary="channeltable" border=1 cellspacing=0>\n<tr>\n};
1079         $HTML .= qq {<th>チャンネル名</th>\n};
1080         $HTML .= qq {<th>チャンネルコード</th>\n};
1081         $HTML .= qq {<th>ontvコード</th>\n};
1082         $HTML .= qq {<th>タイプ</th>\n};
1083         $HTML .= qq {<th>ch</th>\n};
1084         $HTML .= qq {<th>csch</th>\n};
1085         $HTML .= qq {<th>最終更新時刻</th>\n};
1086         $HTML .= qq {<th>状態</th>\n};
1087         $HTML .= qq {</tr>\n};
1088         foreach my $status ( @{$ary_ref} ) {
1089                 $HTML .= qq {<tr>\n};
1090                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1091                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1092                 $HTML .= qq {</tr>\n};
1093         }
1094         $HTML .= qq {</table>\n};
1095
1096         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1097         $HTML .= qq {<div>\n};
1098         $HTML .= qq {番組表を再取得する\n};
1099         $HTML .= qq {<input type="hidden" name="mode" value="expert">\n};
1100         $HTML .= qq {<input type="hidden" name="type" value="reget">\n};
1101         $HTML .= qq {<select name="ch">\n};
1102         $ary_ref = $dbh->selectcol_arrayref(
1103                 "SELECT display FROM ch INNER JOIN chdata ON ch.channel = chdata.ontv WHERE chdata.bctype NOT LIKE '_s%' "
1104         );
1105         foreach my $ch ( @{$ary_ref} ) {
1106                 $HTML .= qq {<option value="$ch">$ch</option>\n};
1107         }
1108         $HTML .= qq {<option value="bs">BS</option>\n};
1109         $HTML .= qq {<option value="cs1">CS1</option>\n};
1110         $HTML .= qq {<option value="cs2">CS2</option>\n};
1111         $HTML .= qq {</select>\n};
1112         $HTML .= qq {<input type="submit" value="実行">\n</div>\n</form>\n};
1113
1114
1115
1116         $ary_ref = $dbh->selectall_arrayref(
1117                 "SELECT id, type, rectime.chtxt, title, btime, etime, deltaday, deltatime
1118                 FROM rectime
1119                 ORDER BY id ");
1120         $HTML .= qq {<hr>\n予約表<br>\n};
1121         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
1122         $HTML .= qq {<th>ID</th>\n};
1123         $HTML .= qq {<th>type</th>\n};
1124         $HTML .= qq {<th>chtxt</th>\n};
1125         $HTML .= qq {<th>title</th>\n};
1126         $HTML .= qq {<th>btime</th>\n};
1127         $HTML .= qq {<th>etime</th>\n};
1128         $HTML .= qq {<th>deltaday</th>\n};
1129         $HTML .= qq {<th>deltatime</th>\n};
1130         $HTML .= qq {</tr>\n};
1131         foreach my $status ( @{$ary_ref} ) {
1132                 $HTML .= qq {<tr>\n};
1133                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1134                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1135                 $HTML .= qq {</tr>\n};
1136         }
1137         $HTML .= qq {</table>\n};
1138 }
1139
1140 if ( $mode eq 'help' ) {
1141         $HTML =~ s/%HTML_TITLE_OPT%/ - Help/;
1142         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1143         $HTML .= qq {<div>\n};
1144         $HTML .= qq {ヘルプ\n};
1145 }
1146
1147 if ( $mode eq 'test' ) {
1148         $HTML =~ s/%HTML_TITLE_OPT%/ - Test/;
1149         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1150         $HTML .= qq {<div>\n};
1151
1152         require Data::Dumper;
1153         require Perl6::Slurp;
1154         $tmp = Perl6::Slurp::slurp( 'config.ini' );
1155         $tmp =~ s/\n/<br>\n/gs;
1156         $HTML .= $tmp;
1157
1158         # $HTML .= Dumper( $ary_ref );
1159 }
1160
1161 if ( !$mode ) {
1162         &draw_form();
1163         $HTML =~ s/%HTML_TITLE_OPT%/ - Top/;
1164         $HTML .= qq {Welcome to Rec10!<br>\n};
1165         goto end;
1166 }
1167
1168
1169 end:
1170 #<div style="float: right">
1171 $HTML .= <<EOM;
1172 </div>
1173 </body>
1174 </html>
1175 EOM
1176
1177 #<div align="center">
1178 $HTML_ADV_TEXT = <<EOM;
1179 <script type="text/javascript"><!--
1180 google_ad_client = "pub-6837289609486635";
1181 /* 728x90, 作成済み 09/07/20 */
1182 google_ad_slot = "6679390404";
1183 google_ad_width = 728;
1184 google_ad_height = 90;
1185 //-->
1186 </script>
1187 <script type="text/javascript"
1188 src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
1189 </script>
1190 EOM
1191
1192 $HTML_ADV_IMG = <<EOM;
1193 <script type="text/javascript"><!--
1194 google_ad_client = "pub-6837289609486635";
1195 /* 728x90, 作成済み 09/07/20 */
1196 google_ad_slot = "5941705087";
1197 google_ad_width = 728;
1198 google_ad_height = 90;
1199 //-->
1200 </script>
1201 <script type="text/javascript"
1202 src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
1203 </script>
1204 EOM
1205
1206 #$HTML_ADV = $HTML_ADV_IMG . $HTML_ADV_TEXT if ( !$HTML_ADV );
1207 $HTML_HEADER = qq {<div style="text-align: center">\n$HTML_ADV\n</div>\n};
1208
1209 &draw_menu();
1210 $HTML =~ s/%HTML_TITLE_OPT%//;
1211 $HTML =~ s/%REFRESH%//;
1212 $HTML =~ s/%SCRIPT%//;
1213 $HTML =~ s/%CSS%//;
1214 $HTML =~ s/%HTML_HEADER%/$HTML_HEADER/;
1215
1216 print $HTTP_HEADER;
1217 print $HTML;
1218
1219 sub draw_menu {
1220         $hires = Time::HiRes::time() - $hires;
1221         $last_modified = localtime((stat 'rectool.pl')[9]);
1222
1223         $HTML_HEADER .= qq {<div>\n};
1224         $HTML_HEADER .= qq {<span style="float: right; font-size: 8px">Last-Modified: $last_modified<br>Time-Elasped: $hires秒</span>\n};
1225         $HTML_HEADER .= qq {<span style="float: left">\n};
1226         $HTML_HEADER .= qq {<a href="rectool.pl">トップ</a>\n};
1227         $HTML_HEADER .= qq {<a href="rectool.pl?mode=schedule">予約確認</a>\n};
1228         $HTML_HEADER .= qq {<a href="rectool.pl?mode=graph">予約状況(画像版)</a>\n};
1229         $HTML_HEADER .= qq {<a href="rectool.pl?mode=list">録画一覧</a>\n};
1230 #       $HTML_HEADER .= qq {<a href="rectool.pl?mode=edit">新規予約</a>\n};
1231         $HTML_HEADER .= qq {<a href="../rec10web/rec10web.py">新規予約</a>\n};
1232         $HTML_HEADER .= qq {</span>\n};
1233         $HTML_HEADER .= qq {<hr style="clear: both; background-color: grey; height: 4px">\n};
1234         $HTML_HEADER .= qq {</div>\n};
1235 }
1236
1237 sub draw_form {
1238         $channel = $dbh->selectrow_array("SELECT channel FROM ch WHERE display = '$display' ");
1239
1240         # チャンネル指定
1241         $HTML .= qq {<div style="float: left">\n};
1242         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1243         $HTML .= qq {<div>\n};
1244         $HTML .= qq {<input type="hidden" name="mode" value="program">\n};
1245         $HTML .= qq {<select name="ch">\n<option value="" selected>無指定</option>\n};
1246         $ary_ref = $dbh->selectcol_arrayref(
1247                 "SELECT display FROM ch INNER JOIN chdata ON ch.channel = chdata.ontv"
1248         );
1249         foreach my $ch ( @{$ary_ref} ) {
1250                 if ( $ch eq $display ) {
1251                         $HTML .= qq {<option value="$ch" selected>$ch</option>\n};
1252                 }
1253                 else {
1254                         $HTML .= qq {<option value="$ch">$ch</option>\n};
1255                 }
1256         }
1257         $HTML .= qq {</select>\n};
1258
1259         # 日付指定
1260         $HTML .= qq {<select name="date">\n<option value="" selected>無指定</option>\n};
1261         $ary_ref = $dbh->selectcol_arrayref(
1262                 "SELECT DISTINCT $SQL{'SUBSTR'} FROM tv"
1263         );
1264         $date_sel = $q->param( 'date' );
1265         foreach my $date ( @{ $ary_ref } ) {
1266                 my @date = $date =~ /(.{4})(.{2})(.{2})/;
1267                 $date_prt = "$date[1]/$date[2]";
1268
1269                 if ( $date eq $date_sel ) {
1270                         $HTML .= qq {<option value="$date" selected>$date_prt</option>\n};
1271                 }
1272                 else {
1273                         $HTML .= qq {<option value="$date">$date_prt</option>\n};
1274                 }
1275         }
1276         $HTML .= qq {</select>\n};
1277
1278         # カテゴリ指定
1279         $HTML .= qq {<select name="category">\n<option value="" selected>無指定</option>\n};
1280         $category_sel = $q->param( 'category' );
1281         foreach my $category ( keys %category ) {
1282                 if ( $category eq $category_sel ) {
1283                         $HTML .= qq {<option value="$category" selected>$category{$category}</option>\n};
1284                 }
1285                 else {
1286                         $HTML .= qq {<option value="$category">$category{$category}</option>\n};
1287                 }
1288         }
1289         $HTML .= qq {</select>\n};
1290
1291         # キーワード指定
1292         $HTML .= qq {<input name="key" type="text" value="$key" style="width:200px">\n};
1293
1294         # フォーム描画
1295         $HTML .= qq {<input type="submit" value="更新">\n</div>\n</form>\n};
1296 }
1297
1298 sub parse_program {
1299         @start   = $start =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
1300         @stop    = $stop  =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
1301         $channel = $dbh->selectrow_array("SELECT channel FROM ch  WHERE display = '$display'");
1302         $title   = $dbh->selectrow_array("SELECT title   FROM tv  WHERE channel = '$channel' AND start = '$start' AND stop = '$stop' ");
1303         $chtxt   = $dbh->selectrow_array("SELECT chtxt   FROM chdata WHERE ontv = '$channel'");
1304         $bctype  = $dbh->selectrow_array("SELECT bctype  FROM chdata WHERE ontv = '$channel'");
1305         if ( $bctype =~ /.s/ ) {
1306                 $bctype = '_s%';
1307         }
1308         elsif ( $bctype =~ /te/ ) {
1309                 $bctype = 'te%';
1310         }
1311         $begin = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @start, '00' );
1312         $end   = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @stop , '00' );
1313 }
1314
1315 sub check_error {
1316         my $is_error = 1;
1317         my @overlap = &get_overlap();
1318
1319         if ( $dbh->selectrow_array(
1320                 "SELECT COUNT(*) FROM rectime
1321                 WHERE chtxt = '$chtxt' AND btime = '$begin' AND etime = '$end'"
1322         ) ) {
1323                 $HTML .= "同一の番組が既に存在します。<br>\n";
1324         }
1325         elsif ( $overlap[0] >= 2 ) {
1326                 $HTML .= "時間が被る番組が既に2個存在します。<br>\n";
1327                 $HTML .= $overlap[1];
1328         }
1329         else {
1330                 $is_error = 0;
1331         }
1332         return $is_error;
1333 }
1334
1335 sub get_overlap {
1336         require List::Util;
1337
1338         my $ary_ref = $dbh->selectall_arrayref(
1339                 "SELECT btime, etime, title
1340                 FROM rectime
1341                 INNER JOIN chdata ON rectime.chtxt = chdata.chtxt
1342                 WHERE bctype LIKE '$bctype' AND type IN ( 'rec', 'res', 'key', 'keyevery', 'tsrecording' )
1343                 AND btime < '$end'
1344                 AND etime > '$begin'
1345                 "
1346         );
1347
1348         my %overlap;
1349         my $overlap = $max = 0;
1350         my $str;
1351         foreach my $prg ( @{ $ary_ref } ) {
1352                 $str .= "$prg->[0] 〜 $prg->[1] : $prg->[2]<br>\n";
1353                 $overlap{$prg->[0]} += 1;
1354                 $overlap{$prg->[1]} -= 1;
1355         }
1356         foreach my $key ( sort keys %overlap ) {
1357                 $overlap += $overlap{$key};
1358                 $max = List::Util::max( $max, $overlap );
1359         }
1360         if ( wantarray ) {
1361                 return ( $max, $str );
1362         }
1363         else {
1364                 return $max;
1365         }
1366 }
1367
1368 sub str2datetime {
1369         my $str    = shift;
1370         my $joined = shift;
1371         my @time;
1372
1373         if ( $joined ) {
1374                 @time = $str =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
1375         }
1376         else {
1377                 @time = $str =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
1378         }
1379         return DateTime->new(
1380                 year => $time[0], month  => $time[1], day    => $time[2],
1381                 hour => $time[3], minute => $time[4], second => $time[5],
1382         );
1383 }
1384