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 use Tie::IxHash;
  21 #require SVG Time::Simple Encode Text::Ngram File::Find Data::Dumper Perl6::Slurp List::Util
  22 #use utf8;
  23 %DB::packages = ( 'main' => 1 );
  24 my $tz = DateTime::TimeZone->new( name => 'local' );
  25 my $hires = Time::HiRes::time();
  26
  27 my $cfg = new Config::Simple;
  28 if ( -e '/etc/rec10.conf' ) {
  29         $cfg->read( '/etc/rec10.conf' );
  30 }
  31 else {
  32         $cfg->read( 'config.ini' );
  33 }
  34
  35 my $sql = $cfg->param( 'db.db' );
  36
  37 if ( $sql eq 'MySQL' ) {
  38         my $name = $cfg->param( 'db.mysql_dbname' );
  39         my $host = $cfg->param( 'db.mysql_host' );
  40         my $port = $cfg->param( 'db.mysql_port' );
  41         my $user = $cfg->param( 'db.mysql_user' );
  42         my $pass = $cfg->param( 'db.mysql_passwd' );
  43         $dbh = DBI->connect("dbi:mysql:$name:$host:$port", $user, $pass, {
  44                 AutoCommit => 1,
  45                 RaiseError => 1,
  46         });
  47         $dbh->do( 'SET NAMES utf8' );
  48 }
  49
  50 my $HTML;
  51
  52 #print "Content-Type: text/html\n\n";
  53
  54 $HTTP_HEADER = "Content-Type: text/html\n\n";
  55 $HTML .= <<EOM;
  56 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
  57 <html lang="ja">
  58 <head>
  59 <title>Rec10%HTML_TITLE_OPT%</title>
  60 <meta http-equiv="Content-Script-Type" content="text/javascript">
  61 <meta http-equiv="Content-Style-Type" content="text/css">
  62 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
  63 <link rev="made" href="Rea10">
  64 <link rel="alternate" type="application/atom+xml" title= "Rec10 Atom Feed" href="./rectool.pl?mode=atom">
  65 %REFRESH%
  66 %SCRIPT%
  67 %CSS%
  68 </head>
  69 <body>
  70 %HTML_HEADER%
  71 EOM
  72
  73
  74 $q = new CGI::Minimal;
  75 $mode = $q->param( 'mode' );
  76 $mode_sub = $q->param( 'mode_sub' );
  77
  78 tie %type, 'Tie::IxHash';
  79 %type = (
  80         'search_everyday'          => '隔日検索',
  81         'search_today'             => '当日検索',
  82         'reserve_flexible'         => '浮動予約',
  83         'reserve_fixed'            => '確定予約',
  84
  85         'reserve_running'          => '録画途中',
  86
  87         'convert_b25_ts'           => '解読予約',
  88         'convert_b25_ts_running'   => '解読途中',
  89         'convert_b25_ts_miss'      => '解読失敗',
  90
  91         'convert_ts_mp4'           => '縁故予約',
  92         'convert_ts_mp4_running'   => '縁故於鯖',
  93         'convert_ts_mp4_network'   => '縁故於網',
  94         'convert_ts_mp4_finished'  => '縁故完了',
  95
  96         'convert_avi_mkv'          => '変換旧露',
  97         'convert_avi_mp4'          => '変換旧四',
  98         'convert_mkv_mp4'          => '変換露四',
  99         'convert_mkv_mp4_runnings' => '換途露四',
 100
 101         'auto_suggest_dec'         => '予測解読',
 102         'auto_suggest_enc'         => '予測縁故',
 103         'auto_suggest_avi2fp'      => '予測旧四',
 104         'auto_suggest_ap2fp'       => '予測露四',
 105
 106         'move_end'                 => '移動完了',
 107 );
 108
 109 %type_suggest = (
 110         'auto_suggest_dec'    => 'convert_b25_ts',
 111         'auto_suggest_enc'    => 'convert_ts_mp4',
 112         'auto_suggest_avi2fp' => 'convert_avi_mkv',
 113         'auto_suggest_ap2fp'  => 'convert_mp4_mkv',
 114 );
 115
 116 $type_user_made = "( 'search_everyday', 'search_today', 'reserve_flexible', 'reserve_fixed', 'reserve_running' )";
 117
 118 %category = (
 119         'etc'         => 'その他',
 120         'news'        => 'ニュース・報道',
 121         'variety'     => 'バラエティ',
 122         'anime'       => 'アニメ・特撮',
 123         'information' => '情報',
 124         'drama'       => 'ドラマ',
 125         'sports'      => 'スポーツ',
 126         'music'       => '音楽',
 127         'cinema'      => '映画',
 128 );
 129
 130 if ( $mode eq 'schedule' ) {
 131
 132         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer/;
 133 #       $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
 134         $css = <<EOM;
 135                 <style type="text/css">
 136                 td {
 137                         white-space: nowrap;
 138                 }
 139                 </style>
 140 EOM
 141         $css =~ s/^\t{2}//gm;
 142         $HTML =~ s/%CSS%/$css/;
 143
 144         my $order = $q->param( 'order' );
 145         my $extra = $q->param( 'extra' );
 146         if ( $order ne 'id' ) {
 147                 $order = 'btime';
 148         }
 149         $reverse_extra = $extra            ? '' : '&amp;extra=1';
 150         $forward_order = $order eq 'btime' ? '' : '&amp;order=id';
 151
 152         my $ary_ref = $dbh->selectall_arrayref(
 153                 "SELECT id, type, epg_ch.chtxt, epg_ch.ontv, epg_ch.chname, title, btime, etime, opt, deltaday, deltatime
 154                 FROM timeline
 155                 INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 156                 ORDER BY $order");
 157
 158         $HTML .= qq {<div style="font-size: 10pt; float: left">\n};
 159         $HTML .= qq {<form method="get" action="rectool.pl">\n};
 160         $HTML .= qq {<div>\n};
 161         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 162         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
 163         $HTML .= qq {<th><a href="rectool.pl?mode=schedule$forward_order$reverse_extra">■</a></th>\n};
 164         $HTML .= qq {<th><a href="rectool.pl?mode=schedule&amp;order=id">ID</a></th>\n};
 165         $HTML .= qq {<th>タイプ</th>\n};
 166         $HTML .= qq {<th>チャンネル</th>\n};
 167         $HTML .= qq {<th>タイトル</th>\n};
 168         $HTML .= qq {<th><a href="rectool.pl?mode=schedule">開始時刻</a></th>\n};
 169         $HTML .= qq {<th>終了時刻</th>\n};
 170         $HTML .= qq {<th>録画時間</th>\n};
 171         $HTML .= qq {<th>オプション</th>\n};
 172         $HTML .= qq {<th>dd</th>\n};
 173         $HTML .= qq {<th>dt</th>\n};
 174         $HTML .= qq {</tr>\n};
 175         foreach my $line ( @{ $ary_ref } ) {
 176
 177                 $type = $type{$line->[1]} || $line->[1];
 178                 if    ( $line->[1] =~ /^search/ ) {
 179                         $type = qq {<span style="color: #8B008B">$type</span>};
 180                         $line->[9]  = qq {<span style="color: #FF0000">空</span>} if ( !$line->[9] && $line->[1] eq 'search_everyday' );
 181                         $line->[10] = qq {<span style="color: #FF0000">空</span>} if ( !$line->[10] );
 182                 }
 183                 elsif ( $line->[1] eq 'reserve_running' ) {
 184                         $type = qq {<span style="color: #FF8C00">$type</span>};
 185                 }
 186                 elsif ( $line->[1] =~ /^reserve/ ) {
 187                         $type = qq {<span style="color: #4169E1">$type</span>};
 188                 }
 189                 elsif ( $line->[1] eq 'convert_b25_ts' ) {
 190                         $type = qq {<span style="color: #BC8F8F">$type</span>};
 191                 }
 192                 elsif ( $line->[1] eq 'convert_b25_ts_running' ) {
 193                         $type = qq {<span style="color: #DC143C">$type</span>};
 194                 }
 195                 elsif ( $line->[1] eq 'convert_ts_mp4' ) {
 196                         $type = qq {<span style="color: #32CD32">$type</span>};
 197                 }
 198                 elsif ( $line->[1] eq 'convert_ts_mp4_running' ) {
 199                         $type = qq {<span style="color: #2E8B57">$type</span>};
 200                 }
 201                 else {
 202                         $type = qq {<span style="color: #A0A0A0">$type</span>};
 203                 }
 204                 $chname_encoded = $q->url_encode( $line->[4] );
 205                 $line->[5] = 'タイトルなし' if ( !$line->[5] );
 206                 my $unix_6 = str2datetime( $line->[6] );
 207                 my $unix_7 = str2datetime( $line->[7] );
 208
 209                 my $btime = $unix_6->strftime( '%Y%m%d%H%M%S' );
 210                 my $etime = $unix_7->strftime( '%Y%m%d%H%M%S' );
 211                 if ( $extra and $line->[1] =~ /^search_|^reserve_/ ) {
 212                         my @ary = $dbh->selectrow_array(
 213                                 "SELECT title, exp FROM epg_timeline
 214                                 WHERE channel = '$line->[3]'
 215                                 AND start = '$btime'
 216                                 AND stop  = '$etime' ");
 217
 218                         if ( $ary[0] ) {
 219                                 $ary[0] =~ s/無料≫//;
 220
 221                                 if ( $ary[0] ne $line->[5] ) {
 222                                         my $count = $ary[0] =~ s/\Q$line->[5]\E//;
 223                                         if ( !$count ) {
 224                                                 $ary[0] = qq {<span style="color: #FF4000">$ary[0]</span>};
 225                                         }
 226                                 }
 227                                 else {
 228                                         $ary[0] = '説明';
 229                                 }
 230
 231                                 if ( $ary[1] ) {
 232                                         $line->[11] = qq {<div style="float: right; cursor: help" title="$ary[1]">$ary[0]</div>};
 233                                 }
 234                                 else {
 235                                         $line->[11] = qq {<span style="float: right">説明なし</span>};
 236                                 }
 237                         }
 238                         else {
 239                                 my $href    = qq {<a href="rectool.pl?mode=edit&amp;id=$line->[0]&amp;suggest=auto">自動検索</a>};
 240                                 $line->[11] = qq {<span style="float: right; color: #FF0000">！$href！</span>};
 241                         }
 242                 }
 243
 244                 my $begin = $unix_6->strftime( '%m/%d(%a) %H:%M' );
 245                 utf8::encode( $begin );
 246                 my $end;
 247                 if ( $unix_6->month == $unix_7->month && $unix_6->day == $unix_7->day )
 248                 {
 249                         $end   = $unix_7->strftime( '%H:%M' );
 250                 }
 251                 else {
 252                         $end   = $unix_7->strftime( '翌 %H:%M' );
 253                 }
 254
 255                 my ( $sec, $min, $hour );
 256                 $sec  = $unix_7->epoch - $unix_6->epoch;
 257                 $min  = int( $sec / 60 );
 258                 $sec  = $sec - $min * 60;
 259                 $hour = int( $min / 60 );
 260                 $min  = $min - $hour * 60;
 261                 my $diff = '';
 262                 $diff .= $hour . '時間' if ( $hour );
 263                 $diff .= $min  . '分'   if ( $min );
 264                 $diff .= $sec  . '秒'   if ( $sec );
 265
 266                 my $hr;
 267                 if (
 268                         $line->[1] eq 'reserve_running'
 269                                 &&
 270                         $unix_6->epoch <= time && time <= $unix_7->epoch
 271                 )
 272                 {
 273                         $percent = int( ( 100 * ( time - $unix_6->epoch ) ) / ( $unix_7->epoch - $unix_6->epoch ) );
 274                         $hr .= qq {<hr style="margin: 0 auto 0 0; height: 4px; width: $percent%;};
 275                         $hr .= qq { background-color: blue; border: none" title="$percent%">};
 276                 }
 277
 278                 $line->[5] = qq {<div style="float: left">$line->[5]</div>} if ( $line->[11] );
 279                 $line->[5] = qq {<a href="rectool.pl?mode=edit&amp;id=$line->[0]">$line->[5]</a>};
 280                 $HTML .= qq {<tr align="center">\n};
 281                 $HTML .= qq {<td><input type="checkbox" name="id" value="$line->[0]"></td>\n};
 282                 $HTML .= qq {<td>$line->[0]</td>\n};
 283                 $HTML .= qq {<td>$type</td>\n};
 284                 $HTML .= qq {<td><a href="rectool.pl?mode=program&amp;chname=$chname_encoded">$line->[2]</a></td>\n};
 285                 $HTML .= qq {<td align="left" style="white-space: normal">$line->[5]$line->[11]</td>\n};
 286                 $HTML .= qq {<td>$begin</td>\n<td>$end</td>\n};
 287                 $HTML .= qq {<td>$hr$diff</td>\n};
 288                 $HTML .= qq {<td>$line->[8]</td>\n<td>$line->[9]</td>\n<td>$line->[10]</td>\n};
 289                 $HTML .= qq {</tr>\n};
 290         }
 291         $HTML .= qq {</table>\n};
 292         $HTML .= qq {<input type="submit" name="edit" value="編集(要JS)">\n};
 293         $HTML .= qq {<input type="submit" name="delete" value="削除">\n</div>\n</form>\n};
 294         goto end;
 295 }
 296
 297 if ( $mode eq 'graph' ) {
 298
 299         $graph = $q->param( 'graph' );
 300
 301         if ( $graph )
 302         {
 303                 print "Content-Type: image/svg+xml\n\n";
 304
 305                 require SVG;
 306                 $graph = Date::Simple->new( split /-/, $graph );
 307                 $graph_bgn = $graph->format('%Y-%m-%d');
 308                 $graph_end = $graph->next->format('%Y-%m-%d');
 309                 $day = $graph->day;
 310                 $today = $graph eq Date::Simple->today() ? 1 : 0;
 311
 312                 $tuner{terrestrial} = 2; #$cfg->param( 'env.te_max' );
 313                 $tuner{satellite}   = 4; #$cfg->param( 'env.bscs_max' );
 314                 $tuner{all} = $tuner{terrestrial} + $tuner{satellite};
 315                 $hours = 24;
 316                 $width = 30 * $hours;
 317
 318                 $svg = new SVG( width => 820, height => $tuner{all} * 20 + 40 );
 319                 $svg->rectangle( 'x' => 40, 'y' => 20,
 320                         width => $width + 20, height => $tuner{all} * 20 + 10,
 321                         rx => 15, ry => 15,
 322                         style => { stroke => 'blue', fill => 'white' } );
 323                 for ( 1..$tuner{terrestrial} ) {
 324                         $svg->text( 'x' => 10, 'y' => ( $_ + 1 ) * 20 )
 325                                 ->cdata( "T$_" );
 326                 }
 327                 for ( 1..$tuner{satellite} ) {
 328                         $svg->text( 'x' => 10, 'y' => ( $_ + $tuner{terrestrial} + 1 ) * 20 )
 329                                 ->cdata( "S$_" );
 330                 }
 331                 for ( 0..$hours ) {
 332                         $svg->text( 'x' => $_ * 30 + 65, 'y' => 15,
 333                                 style => { 'text-anchor' => 'middle' } )
 334                                 ->cdata( sprintf( '%02d', $_ ) ) if ( $_ < $hours );
 335                         # $svg->line( ); # can't use when required
 336                         $svg->tag( 'line', x1 => $_ * 30 + 50, x2 => $_ * 30 + 50, y1 => 30, y2 => $tuner{all} * 20 + 20,
 337                                 style => { stroke => 'gray' } );
 338                 }
 339                 for ( 1..$tuner{all} ) {
 340                         $svg->rectangle( 'x' => 50, 'y' => $_ * 20 + 10, width => $width, height => 10 );
 341                 }
 342                 if ( $today ) {
 343                         require Time::Simple;
 344                         my $time = Time::Simple->new();
 345                         my $x = ( $time->hours * 60 + $time->minutes ) * 0.5 + 50;
 346                         $svg->tag( 'line', x1 => $x, x2 => $x, y1 => 30, y2 => $tuner{all} * 20 + 20,
 347                                 style => { stroke => 'red', 'fill-opacity' => '1.0' } );
 348                 }
 349                 foreach my $bctype ( 'te%', '_s%' ) {
 350                         my $tuner = $bctype eq 'te%' ? $tuner{terrestrial} : $tuner{satellite};
 351                         my $ary_ref = $dbh->selectall_arrayref(
 352                                 "SELECT id, type, timeline.chtxt, title, btime, etime, opt FROM timeline
 353                                 INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 354                                 WHERE epg_ch.bctype LIKE '$bctype'
 355                                 AND type IN $type_user_made
 356                                 AND
 357                                 (
 358                                         '$graph_bgn 00:00' <= btime AND btime <  '$graph_end 00:00'
 359                                                 OR
 360                                         '$graph_bgn 00:00' <  etime AND etime <= '$graph_end 00:00'
 361                                 )
 362                                 ORDER BY id"
 363                         );
 364                         foreach my $line ( @{ $ary_ref } ) {
 365                                 @start = $line->[4] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 366                                 @stop  = $line->[5] =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 367                                 $start = ( ( $day == $start[2] ? 0 : 24 * 60 ) + $start[3] * 60 + $start[4] ) * 0.5;
 368                                 $stop  = ( ( $day == $stop [2] ? 0 : 24 * 60 ) + $stop [3] * 60 + $stop [4] ) * 0.5;
 369                                 $start = 0      if ( $start < 0 || $day > $start[2] ); # 月の変わり目はスルー
 370                                 $stop  = $width if ( $stop  > $width );
 371                                 $begin = $line->[4];
 372                                 $end   = $line->[5];
 373
 374                                 my $ary = $dbh->selectall_arrayref(
 375                                         "SELECT id, type, timeline.chtxt, title, btime, etime, opt FROM timeline
 376                                         INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 377                                         WHERE epg_ch.bctype LIKE '$bctype'
 378                                         AND type IN $type_user_made
 379                                         AND NOT
 380                                         (
 381                                                 ( etime <= '$begin' )
 382                                                         OR
 383                                                 ( btime >= '$end'   )
 384                                         )
 385                                         ORDER BY id"
 386                                 );
 387                                 my @ary = @{$ary};
 388                                 for ( 0..$tuner - 1 ) {
 389                                         $f = 1;
 390                                         $i = $_;
 391                                         for ( 0..4 ) {
 392                                                 $f = 0 if ( $line->[$_] ne $ary[$i]->[$_] );
 393                                         }
 394                                         if ( $f ) {
 395                                                 $slot = $i;
 396                                         }
 397                                 }
 398                                 my ( $r, $g, $b ) = ( 0, 0, 0 );
 399                                 $r += 255 if ( $line->[6] =~ /a/ );
 400                                 $g += 255 if ( $line->[6] =~ /H/ );
 401                                 $b += 255 if ( $line->[6] =~ /2/ );
 402                                 if ( $r + $g + $b == 255 * 3 ){
 403                                         $r = 0;
 404                                         $g = 255;
 405                                         $b = 255;
 406                                 }
 407                                 if ( $r + $g + $b == 0 ){
 408                                         $r = $g = $b = 128;
 409                                 }
 410                                 my %escaped = ( '&' => 'amp', '<' => 'lt', '>' => 'gt', '"' => 'quot' );
 411                                 sub html_escape{
 412                                     my $str = shift or return;
 413                                     my $result = '';
 414                                     $result .= $escaped{$_} ? '&' . $escaped{$_} . ';' : $_
 415                                         for (split //, $str);
 416                                     $result;
 417                                 }
 418                                 $svg->anchor(
 419                                         -href  => "rectool.pl?mode=edit&amp;id=$line->[0]",
 420                                         target => '_blank',
 421                                         -title => html_escape( $line->[3] ),
 422                                 )->rectangle(
 423                                         'x' => 50 + $start,
 424                                         'y' => 30 + ( $bctype eq 'te%' ? 0 : $tuner{terrestrial} * 20 ) + $slot * 20,
 425                                         width  => $stop - $start,
 426                                         height => 10,
 427                                         style  => { fill => "rgb($r,$g,$b)" } );
 428                         }
 429                 }
 430                 print $svg->xmlify;
 431                 exit;
 432         }
 433         else
 434         {
 435                 $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer - Graphical/;
 436                 $HTML .= qq {<div style="float: left">\n};
 437                 # $base64 = encode_base64( $svg->xmlify );
 438                 # $HTML .= qq {<object data="data:image/svg+xml;base64,$base64">\n</object>\n};
 439                 $HTML .= qq {予約状況一覧です。T1,T2は地上波、S1,S2はBS/CS、赤はアニメ、緑はHD、青は2 passを示しています。<br>\n};
 440                 $HTML .= qq {SVGが利用可能なブラウザでご覧ください。<br>\n};
 441
 442                 $ary_ref = $dbh->selectcol_arrayref(
 443                         "SELECT DISTINCT DATE( btime )
 444                         FROM timeline
 445                         WHERE type in $type_user_made
 446                         ORDER BY btime"
 447                 );
 448                 foreach my $date ( @{ $ary_ref } ) {
 449                         my @date = $date =~ /(.{4})-(.{2})-(.{2})/;
 450                         my $dn = DateTime->new( year => $date[0], month => $date[1], day => $date[2], locale => 'ja_JP' )->day_name;
 451                         utf8::encode( $dn );
 452                         $HTML .= qq {$date[1]/$date[2]($dn)の予約状況<br>\n};
 453                         $HTML .= qq {<object type="image/svg+xml" data="rectool.pl?mode=graph&amp;graph=$date" width="820">\n};
 454                         $HTML .= qq {SVG Image $date\n</object>\n<br>\n};
 455
 456                         $date2 = Date::Simple->new( @date )->next->format('%Y-%m-%d');
 457                         my $ary_ref = $dbh->selectall_arrayref(
 458                                 "SELECT chtxt, title, btime, etime FROM timeline
 459                                 WHERE '$date 00:00' <= btime AND etime <= '$date2 01:00'
 460                                 ORDER BY btime"
 461                         );
 462
 463                         foreach my $line ( @{ $ary_ref } ) {
 464 #                               $HTML .= qq {$line->[0] $line->[1] $line->[2] $line->[3]<br>\n};
 465                         }
 466
 467                 }
 468
 469                 goto end;
 470         }
 471 }
 472
 473 if ( $mode eq 'atom' ) {
 474         require XML::Atom::Feed;
 475         require XML::Atom::Entry;
 476
 477         my $recording_status;
 478         my $ary_ref = $dbh->selectall_arrayref(
 479                 "SELECT chtxt, title, btime, etime, opt
 480                 FROM timeline
 481                 WHERE type = 'reserve_running' ");
 482         foreach my $line ( @{$ary_ref} ) {
 483                 my ( $begin, $end, $diff ) = &str2readable( $line->[2], $line->[3] );
 484                 $recording_status .= qq {$line->[0] $line->[1] $begin - $end $diff $line->[4]};
 485         }
 486
 487         my $feed = XML::Atom::Feed->new;
 488         $feed->title('Rec10 フィード');
 489
 490         my $entry = XML::Atom::Entry->new;
 491         $entry->title('Rec10 録画状況');
 492         $entry->id('tag:recording_status');
 493         $entry->content($recording_status);
 494         $feed->add_entry($entry);
 495
 496         $entry = XML::Atom::Entry->new;
 497         $entry->title('Test');
 498         $entry->id('testid');
 499         $entry->content('TestData');
 500         $feed->add_entry($entry);
 501
 502         my $xml = $feed->as_xml;
 503         print "Content-Type: application/atom+xml\n\n";
 504         print $xml;
 505         exit;
 506 }
 507
 508 if ( $mode eq 'edit' ) {
 509         my $id = $q->param( 'id' );
 510
 511         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Editor/;
 512         $HTML .= qq {<div style="float: left">\n};
 513
 514         $script = <<EOM;
 515                 <script type="text/javascript" src="http://www.enjoyxstudy.com/javascript/dateformat/dateformat.js">
 516                 </script>
 517                 <script type="text/javascript">
 518                 function setType(value){
 519                         var index = document.reserve.type.selectedIndex;
 520                         var value = document.reserve.type[index].value;
 521                         if ( value == 'search_everyday' ) {
 522                                 document.reserve.deltaday.value  = 7;
 523                                 document.reserve.deltatime.value = 3;
 524                         }
 525                         if ( value == 'convert_b25_ts' || value == 'convert_ts_mp4' ){
 526                                 var date       = new Date();
 527                                 var dateFormat = new DateFormat("yyyy-MM-dd HH:mm:ss");
 528                                 var minutes    = date.getMinutes();
 529                                 minutes = minutes - minutes % 5 + 10;
 530                                 date.setMinutes(minutes, 0, 0);
 531                                 document.reserve.begin.value = dateFormat.format(date);
 532                                 date.setSeconds( date.getSeconds() + 3600 );
 533                                 document.reserve.end.value   = dateFormat.format(date);
 534                         }
 535                 }
 536                 function setSuggest(start, stop){
 537                         document.reserve.begin.value = start;
 538                         document.reserve.end.value   = stop;
 539                 }
 540                 function shiftEndTime(value){
 541                         var dateFormat = new DateFormat("yyyy-MM-dd HH:mm:ss");
 542                         var date = dateFormat.parse(document.reserve.end.value || document.reserve.begin.value);
 543                         date.setSeconds( date.getSeconds() + value );
 544                         document.reserve.end.value = dateFormat.format(date);
 545                 }
 546                 </script>
 547 EOM
 548         $script =~ s/^\t{2}//gm;
 549         $HTML =~ s/%SCRIPT%/$script/;
 550
 551         $HTML .= "スケジュール編集画面です。<br>\n";
 552         $HTML .= "実装がとても適当なので、利用には細心の注意を払ってください。<br>\n<br>\n";
 553         if ( $id ) {
 554                 &parse_program();
 555                 $button_bgn = $button_end = '';
 556         }
 557         else {
 558                 $type = 'reserve_flexible';
 559                 $datetime_now = DateTime->now( time_zone => $tz )->set_second( 0 )->add( minutes => 1)->strftime( '%Y-%m-%d %H:%M:%S' );
 560                 $button_bgn = qq{<button type="button" onClick="document.reserve.begin.value='$datetime_now'">現在</button>\n<br>\n};
 561                 $button_end =
 562                          qq{<button type="button" onClick="document.reserve.end.value=document.reserve.begin.value">一致</button>}
 563                         .qq{<button type="button" onClick="shiftEndTime(300);">+5m</button>}
 564                         .qq{<button type="button" onClick="shiftEndTime(1800);">+30m</button>};
 565         }
 566
 567         if ( $q->param( 'suggest' ) eq 'auto' ) {
 568                 my @btime = $begin =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 569                 my @etime = $end   =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 570                 my $btime = DateTime->new(
 571                         year => $btime[0], month  => $btime[1], day    => $btime[2],
 572                         hour => $btime[3], minute => $btime[4], second => $btime[5],
 573                 );
 574                 my $etime = DateTime->new(
 575                         year => $etime[0], month  => $etime[1], day    => $etime[2],
 576                         hour => $etime[3], minute => $etime[4], second => $etime[5],
 577                 );
 578                 my %hash = &sqlgetsuggested( $btime, $etime );
 579
 580                 $HTML .= qq {可能性のある番組<br>\n};
 581                 $HTML .= qq {<table summary="suggesttable" border=1 cellspacing=0>\n<tr>\n};
 582                 $HTML .= qq {<th>優先度</th>\n};
 583                 $HTML .= qq {<th>タイトル</th>\n};
 584                 $HTML .= qq {<th>開始時刻</th>\n};
 585                 $HTML .= qq {<th>終了時刻</th>\n};
 586                 $HTML .= qq {<th>説明</th>\n};
 587                 $HTML .= qq {<th>適用</th>\n};
 588                 $HTML .= qq {</tr>\n};
 589
 590                 foreach my $key (sort keys %hash){
 591                         my $val = $hash{$key};
 592                         foreach my $val ( @{$val} ) {
 593                                 my $style = qq {style="white-space: nowrap"};
 594                                 $val->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 595                                 $val->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 596                                 $HTML .= qq {<tr>\n<td>$key</td>\n<td>$val->[2]</td>\n};
 597                                 $HTML .= qq {<td $style>$val->[0]</td>\n<td $style>$val->[1]</td>\n<td>$val->[3]</td>\n};
 598                                 $HTML .= qq {<td><button onClick="setSuggest('$val->[0]','$val->[1]');">適用</button></td>\n</tr>\n};
 599                         }
 600                 }
 601                 $HTML .= qq {</table>\n<br>\n};
 602         }
 603
 604         my $len = length $id;
 605         $HTML .= qq {<form method="get" action="rectool.pl" name="reserve">\n};
 606         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 607         $HTML .= qq {<input type="hidden" name="mode_sub" value="update">\n};
 608         $HTML .= qq {<input type="hidden" name="id" value="$id">\n};
 609         $HTML .= qq {ID\n<input type="text" name="id" value="$id" size=$len disabled>\n};
 610         $HTML .= qq {タイプ\n<select name="type" onChange="setType();">\n};
 611         foreach my $key ( keys %type ) {
 612                 next if ( $key !~ /^search|^reserve|^convert_b25_ts$|^convert_ts_mp4$|^$type$/ );
 613                 $value = $type{$key};
 614                 if ( $key eq $type ) {
 615                         $HTML .= qq {<option value="$key" selected>$value</option>\n};
 616                 }
 617                 else {
 618                         $HTML .= qq {<option value="$key">$value</option>\n};
 619                 }
 620         }
 621         $HTML .= qq {</select>\n};
 622         $HTML .= qq {チャンネル\n<select name="chtxt">\n};
 623         $ary_ref = $dbh->selectall_arrayref(
 624                 "SELECT chname, chtxt FROM epg_ch"
 625         );
 626         foreach my $line ( @{$ary_ref} ) {
 627                 if ( $line->[1] eq $chtxt ) {
 628                         $HTML .= qq {<option value="$line->[1]" selected>$line->[0]</option>\n};
 629                 }
 630                 else {
 631                         $HTML .= qq {<option value="$line->[1]">$line->[0]</option>\n};
 632                 }
 633         }
 634         $HTML .= qq {</select><br>\n};
 635         $HTML .= qq {タイトル\n<input type="text" name="title" value="$title" size=64><br>\n};
 636         $HTML .= qq {開始時刻\n<input type="text" name="begin" value="$begin" maxlength=19 size=24>\n};
 637         $HTML .= $button_bgn;
 638         $HTML .= qq {終了時刻\n<input type="text" name="end" value="$end" maxlength=19 size=24>\n};
 639         $HTML .= $button_end . "<br>\n";
 640         $HTML .= qq {隔日周期\n<input type="text" name="deltaday" value="$deltaday" maxlength=2  size=2 >\n};
 641         $HTML .= qq {時刻誤差\n<input type="text" name="deltatime" value="$deltatime" maxlength=2  size=2 >\n};
 642         $HTML .= qq {オプション\n<input type="text" name="opt" value="$opt">\n};
 643         $HTML .= qq {<input type="submit" name="update" value="更新">\n</form>\n};
 644 }
 645
 646 if ( $mode eq 'change' ) {
 647         @id     = $q->param( 'id' );
 648
 649         $HTML =~ s/%HTML_TITLE_OPT%/ - Change/;
 650         $HTML .= qq {<div style="float: left">\n};
 651
 652         if ( $q->param( 'delete' ) )
 653         {
 654                 if ( @id ) {
 655                         foreach my $id ( @id ) {
 656                                 $dbh->do( "DELETE FROM timeline WHERE id = '$id'" );
 657                         }
 658                         $HTML .= "削除しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 659                         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 660                         goto end;
 661                 }
 662         }
 663         if ( $q->param( 'update' ) )
 664         {
 665                 $type      = $q->param( 'type' );
 666                 $chtxt     = $q->param( 'chtxt' );
 667                 $title     = $q->param( 'title' );
 668                 $begin     = $q->param( 'begin' );
 669                 $end       = $q->param( 'end' );
 670                 $deltaday  = $q->param( 'deltaday' );
 671                 $deltatime = $q->param( 'deltatime' );
 672                 $opt       = $q->param( 'opt' );
 673                 $id        = $id[0];
 674                 if ( $id ) {
 675                         $dbh->do(
 676                                 "UPDATE timeline SET type = '$type', chtxt = '$chtxt', title = '$title',
 677                                 btime = '$begin', etime = '$end',
 678                                 deltaday = '$deltaday', deltatime = '$deltatime', opt = '$opt'
 679                                 WHERE id = '$id'"
 680                         );
 681                 }
 682                 else {
 683                         $dbh->do(
 684                                 "INSERT INTO timeline ( type, chtxt, title, btime, etime, deltaday, deltatime, opt )
 685                                 VALUES ( '$type', '$chtxt', '$title', '$begin', '$end', '$deltaday', '$deltatime', '$opt' )"
 686                         );
 687                 }
 688                 $HTML .= "更新しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 689                 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 690                 goto end;
 691         }
 692         if ( $mode_sub eq 'proc' ) {
 693                 my $type  = $q->param( 'type' );
 694                 my $chtxt = $q->param( 'chtxt' ) || 'nhk-k';
 695                 my $title = $q->param( 'title' );
 696                 my @opt   = $q->param( 'opt' );
 697                 my $opt   = join '', @opt;
 698
 699                 my $datetime_now = DateTime->now( time_zone => $tz )->set_second( 0 )->add( minutes => 10);
 700                 my $sql_type = $type_suggest{$type};
 701                 my $begin = $datetime_now->strftime( '%Y-%m-%d %H:%M:%S' );
 702                 $datetime_now = $datetime_now->add( minutes => 60 );
 703                 my $end = $datetime_now->strftime( '%Y-%m-%d %H:%M:%S' );
 704
 705                 $dbh->do(
 706                         "INSERT INTO timeline ( type, chtxt, title, btime, etime, opt )
 707                         VALUES ( '$sql_type', '$chtxt', '$title', '$begin', '$end', '$opt' )"
 708                 );
 709
 710                 goto end;
 711         }
 712         if ( $mode_sub eq 'move' ) {
 713                 my $mode_sub2  = $q->param( 'mode_sub2' );
 714                 my $title      = $q->param( 'title' );
 715                 $title =~ s/＃/#/g;
 716                 $title =~ s/\+/ /g;
 717
 718                 $ENV{'LANG'} = 'ja_JP.UTF-8';
 719                 if ( $mode_sub2 eq 'predict' ) {
 720                         eval '$HTML .= `python26 ' . $cfg->param( 'path.rec10' ) . "classify.py -s '$title'`";
 721                 }
 722                 elsif ( $mode_sub2 eq 'exec' ) {
 723                         eval '$HTML .= `python26 ' . $cfg->param( 'path.rec10' ) . "classify.py -e '$title'`";
 724                 }
 725
 726                 goto end;
 727         }
 728
 729 }
 730
 731 if ( $mode eq 'confirm' ) {
 732         if ( $mode_sub eq 'reserve' ) {
 733                 $HTML =~ s/%HTML_TITLE_OPT%/ - Reserver/;
 734                 $HTML .= qq {<div style="float: left">\n};
 735                 &parse_program();
 736
 737                 my $duration = ( str2datetime( $end ) - str2datetime( $begin ) )->delta_minutes;
 738                 $HTML .= "番組名：$title<br>\nチャンネル：$chname<br>\n放送継続時間：$duration分<br>\n番組内容：$desc<br>\n";
 739                 if ( $longdesc ) {
 740                         $longdesc =~ s/\\n/<br>\n/gs;
 741                         $HTML .= "番組内容(長)：$longdesc<br>\n";
 742                 }
 743                 my $error = &check_error();
 744                 if ( $error )
 745                 {
 746                         # エラー
 747
 748                         $ary_ref = $dbh->selectall_arrayref(
 749                                 "SELECT start, stop FROM epg_timeline WHERE channel = '$ontv' AND title = '$title' "
 750                         );
 751                         if ( $error != 1 ) {
 752                                 $HTML .= "同一の番組の他の放送予定です。<br>\n";
 753                                 foreach my $line ( @{$ary_ref} ) {
 754                                         $begin = $line->[0];
 755                                         $end   = $line->[1];
 756                                         $begin =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 757                                         $end   =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 758                                         $overlap = &get_overlap() >= 2 ? '不可能' :
 759                                                 qq {<a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chname=$chname&amp;start=$line->[0]&amp;stop=$line->[1]">可能</a>};
 760                                         $HTML .= "開始：$begin\n終了：$end\n録画は$overlap<br>\n";
 761                                 }
 762                         }
 763                 }
 764                 else {
 765                         if ( $chtxt  =~ /\Qbs-nhk-hi\E/ ) {
 766                                 $selected_f = 'selected';
 767                         }
 768                         elsif ( $chtxt  =~ /movieplus/ ) {
 769                                 $selected_h = 'selected';
 770                         }
 771                         else {
 772                                 $selected_g = 'selected';
 773                         }
 774                         $checked_v = $chtxt =~ /animax|atx|disney|kids/ || $category =~ /アニメ/ ? 'checked' : '';
 775                         $checked_d = $title =~ /\Q[二]\E|［二］|\Q(二)\E|（二）/ ? 'checked' : '';
 776                         $checked_5 = $title =~ /5\.1|5．1/ ? 'checked' : '';
 777                         $checked_2 = 'checked';
 778
 779                         $HTML .= "録画予約の詳細設定を行ってください。<br>\n";
 780                         $HTML .= qq {<form method="get" action="rectool.pl">\n};
 781                         $HTML .= qq {<input type="hidden" name="mode"   value="reserve">\n};
 782                         $HTML .= qq {<input type="hidden" name="chname" value="$chname">\n};
 783                         $HTML .= qq {<input type="hidden" name="start"  value="$start">\n};
 784                         $HTML .= qq {<input type="hidden" name="stop"   value="$stop">\n};
 785                         $HTML .= qq {<select name="opt">\n};
 786                         $HTML .= qq {<option value="L" $selected_l>L ***x*** 1250kbps</option>\n};
 787                         $HTML .= qq {<option value="G" $selected_g>G 1280x720 2500kbps</option>\n};
 788                         $HTML .= qq {<option value="H" $selected_h>H 1280x720 3750kbps</option>\n};
 789                         $HTML .= qq {<option value="F" $selected_f>F 1920x1080 5000kbps</option>\n};
 790                         $HTML .= qq {<option value="S">S 720x480 1250kbps</option>\n};
 791                         $HTML .= qq {</select>\n};
 792                         $HTML .= qq {<input type="checkbox" name="opt" value="v" $checked_v>可変フレームレート\n};
 793                         $HTML .= qq {<input type="checkbox" name="opt" value="d" $checked_d>二ヶ国語放送\n};
 794                         $HTML .= qq {<input type="checkbox" name="opt" value="2" $checked_2>2passモード\n};
 795                         $HTML .= qq {<input type="checkbox" name="opt" value="5" $checked_5>5.1ch放送\n};
 796                         $HTML .= qq {<br>\n};
 797                         $HTML .= qq {<select name="opt">\n};
 798                         $HTML .= qq {<option value="">移動なし</option>\n};
 799                         $HTML .= qq {<option value="R">録画後移動</option>\n};
 800                         $HTML .= qq {<option value="D">解読後移動</option>\n};
 801                         $HTML .= qq {<option value="E">縁故後移動</option>\n};
 802                         $HTML .= qq {</select>\n};
 803                         $HTML .= qq {<input type="checkbox" name="opt" value="N">ファイル名日時追加\n};
 804                         $HTML .= qq {<input type="checkbox" name="every" value="1">隔週録画\n};
 805                         $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
 806                 }
 807                 goto end;
 808         }
 809         # End of $mode_sub eq 'reserve';
 810
 811         if ( $mode_sub eq 'proc' ) {
 812                 my $type  = $q->param( 'type' );
 813                 my $chtxt = $q->param( 'chtxt' );
 814                 my $title = $q->param( 'title' );
 815
 816                 $HTML .= "詳細設定を行ってください。<br>\n";
 817                 $HTML .= "タイトル：$title\n<br>\n";
 818
 819                 $HTML .= qq {<form method="get" action="rectool.pl">\n};
 820                 $HTML .= qq {<input type="hidden" name="mode"     value="change">\n};
 821                 $HTML .= qq {<input type="hidden" name="mode_sub" value="proc">\n};
 822                 $HTML .= qq {<input type="hidden" name="type"     value="$type">\n};
 823                 $HTML .= qq {<input type="hidden" name="title"    value="$title">\n};
 824                 $HTML .= qq {<select name="chtxt">\n};
 825                 $ary_ref = $dbh->selectall_arrayref(
 826                         "SELECT chname, chtxt FROM epg_ch"
 827                 );
 828                 foreach my $line ( @{$ary_ref} ) {
 829                         if ( $line->[1] eq $chtxt ) {
 830                                 $HTML .= qq {<option value="$line->[1]" selected>$line->[0]</option>\n};
 831                         }
 832                         else {
 833                                 $HTML .= qq {<option value="$line->[1]">$line->[0]</option>\n};
 834                         }
 835                 }
 836                 $HTML .= qq {</select>\n};
 837
 838                 $HTML .= qq {<select name="opt">\n};
 839                 $HTML .= qq {<option value="L" $selected_l>L ***x*** 1250kbps</option>\n};
 840                 $HTML .= qq {<option value="G" $selected_g>G 1280x720 2500kbps</option>\n};
 841                 $HTML .= qq {<option value="H" $selected_h>H 1280x720 3750kbps</option>\n};
 842                 $HTML .= qq {<option value="F" $selected_f>F 1920x1080 5000kbps</option>\n};
 843                 $HTML .= qq {<option value="S">S 720x480 1250kbps</option>\n};
 844                 $HTML .= qq {</select>\n};
 845                 $HTML .= qq {<input type="checkbox" name="opt" value="a" $checked_a>アニメ\n};
 846                 $HTML .= qq {<input type="checkbox" name="opt" value="d" $checked_d>二ヶ国語放送\n};
 847                 $HTML .= qq {<input type="checkbox" name="opt" value="2" $checked_2>2passモード\n};
 848                 $HTML .= qq {<input type="checkbox" name="opt" value="5" $checked_5>5.1ch放送\n};
 849                 $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
 850                 goto end;
 851         }
 852 }
 853
 854 if ( $mode eq 'reserve' ) {
 855         $HTML .= qq {<div style="float: left">\n};
 856         &parse_program();
 857         @opt = $q->param( 'opt' );
 858         $opt = join '', @opt;
 859         my ( $deltaday, $deltatime );
 860                 $deltaday = 7;
 861         if ( $q->param('every') eq '1' ) {
 862                 $type = 'search_everyday';
 863                 ( $changed_t ) = $title =~ /(.*) #/;
 864                 $title = $changed_t if ( $changed_t );
 865                 ( $changed_t ) = $title =~ /(.*) 第/;
 866                 $title = $changed_t if ( $changed_t );
 867                 $title =~ s/「.*」//;
 868                 $title =~ s/＜.*＞//;
 869                 $title =~ s/（.*）//;
 870                 $deltaday  = 7;
 871                 $deltatime = 3;
 872         }
 873         else {
 874                 $type = 'reserve_flexible';
 875         }
 876         if ( !&check_error ) {
 877                 $dbh->do(
 878                         "INSERT INTO timeline ( type, chtxt, title, btime, etime, opt, deltaday, deltatime )
 879                         VALUES ( '$type', '$chtxt', '$title', '$begin', '$end', '$opt', '$deltaday', '$deltatime' )"
 880                 );
 881         }
 882         $HTML .= "録画予約を実行しました。<br>\n5秒後にトップへ移動します。<br>\n";
 883         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl">|;
 884         goto end;
 885 }
 886
 887 if ( $mode eq 'program' ) {
 888         &draw_form();
 889
 890         $HTML =~ s/%HTML_TITLE_OPT%/ - Program Viewer/;
 891         $unix = DateTime->now( time_zone => $tz )->strftime( '%Y%m%d%H%M%S' );
 892         $sql =
 893                 "SELECT channel, chname, start, stop, title, category
 894                 FROM epg_timeline
 895                 INNER JOIN epg_ch ON epg_timeline.channel = epg_ch.ontv
 896                 WHERE $unix <= stop %CH% %DATE% %CATEGORY% %KEY% ORDER BY start";
 897
 898         if ( $ontv ) {
 899                 my $ch = "AND channel = '$ontv'";
 900                 $sql =~ s/%CH%/$ch/;
 901         }
 902         if ( $date_sel ) {
 903                 $date_1 = $date_sel . '000000';
 904                 $date_2 = Date::Simple->new( $date_sel =~ /(.{4})(.{2})(.{2})/ )->next->format('%Y%m%d') . '000000';
 905                 my $date = "AND '$date_1' <= stop AND start <= '$date_2'";
 906                 $sql =~ s/%DATE%/$date/;
 907         }
 908         if ( $category_sel ) {
 909                 # 一時的
 910                 #       $category_tmp = $category{$category_sel} . $category_sel;
 911                 my $category = "AND category = '$category{$category_sel}'";
 912                 $sql =~ s/%CATEGORY%/$category/;
 913         }
 914         if ( $key ) {
 915                 my $key = "AND TITLE LIKE '%$key%'";
 916                 $sql =~ s/%KEY%/$key/;
 917         }
 918         $sql =~ s/%CH%//;
 919         $sql =~ s/%DATE%//;
 920         $sql =~ s/%KEY%//;
 921         $sql =~ s/%CATEGORY%//;
 922
 923         $ary_ref = $dbh->selectall_arrayref( $sql );
 924         foreach my $prg ( @{ $ary_ref } ) {
 925                 my @date = $prg->[2] =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
 926
 927                 $date = $date[2];
 928                 if ( $date != $prev ) {
 929                         my $date = DateTime->new(
 930                                 year => $date[0], month  => $date[1], day    => $date[2],
 931                                 locale => 'ja_JP'
 932                         );
 933
 934                         my $dn = $date->day_name;
 935                         utf8::encode( $dn );
 936                         $HTML .= qq {--------$date[1]/$date[2]($dn)--------<br>\n};
 937                 }
 938                 $prg->[5] = $q->url_encode( $prg->[1] );
 939                 $HTML .= qq {$date[1]/$date[2] $date[3]:$date[4] };
 940                 $HTML .= qq {$prg->[1] } if ( !$ontv );
 941                 $HTML .= qq {<a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chname=$prg->[5]&amp;start=$prg->[2]&amp;stop=$prg->[3]">$prg->[4]</a><br>\n};
 942                 $prev = $date;
 943         }
 944
 945 }
 946
 947 if ( $mode eq 'list' ) {
 948         require File::Find;
 949
 950         $HTML =~ s/%HTML_TITLE_OPT%/ - List/;
 951
 952         my $recording = $cfg->param( 'path.recpath' );
 953         my $recorded  = $cfg->param( 'path.recorded' );
 954
 955         if ( !$mode_sub ) {
 956                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;mode_sub=new">録画中のみ</a>\n};
 957                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;mode_sub=old">録画後のみ</a>\n<br>\n};
 958         }
 959         if ( !$mode_sub || $mode_sub eq 'new' ) {
 960                 $HTML .= "録画中のファイル一覧<br>\n";
 961                 &list( $recording );
 962         }
 963         if ( !$mode_sub ) {
 964                 $HTML .= "<br>\n";
 965         }
 966         if ( !$mode_sub || $mode_sub eq 'old' ) {
 967                 $HTML .= "録画後のファイル一覧<br>\n";
 968                 &simple_list( $recorded );
 969         }
 970
 971         sub list {
 972                 local $path = shift;
 973                 local %list = ();
 974                 my @exp = ( 'log', 'ts.b25', 'ts.tsmix', 'ts', 'ts.log.mbtree', 'ts.log',
 975                         'sa.avi', 'sa.avi.log', '120.avi', 'aac', 'timecode.txt', 'm2v', 'wav', 'avi', 'mkv', 'mp4' );
 976                 for ( 0..$#exp ) {
 977                         $exp{$exp[$_]} = $_;
 978                 }
 979                 my $exp_count = scalar keys %exp;
 980
 981                 my %opt = ( follow => 1, wanted => \&wanted,  );
 982                 File::Find::find( \%opt, $path );
 983
 984                 foreach my $name ( sort { $exp{$a} <=> $exp{$b} } keys %exp ) {
 985                         $HTML .= $exp{$name} + 1 . " = $name / ";
 986                 }
 987                 $HTML .= $exp_count+1 . qq { = サムネイル<br>\n○ = 完了 / ● = 書き込み中 / ◆ = ファイルサイズ異常<br>\n};
 988                 $HTML .= qq {<table summary="listtable" border=1 cellspacing=0>\n<tr>\n};
 989                 $HTML .= qq {<th>タイトル</th>\n};
 990                 $HTML .= qq {<th>$_</th>\n} for ( 1..$exp_count + 1 );
 991                 $HTML .= qq {<th colspan="2">自動移動</th>\n};
 992                 $HTML .= qq {</tr>\n};
 993
 994                 foreach ( sort keys %list ) {
 995                         my $value = $list{$_};
 996                         my @flag = ( 0 ) x $exp_count;
 997                         $HTML .= qq {<tr>\n<td width="600" style="width: 600px; white-space: normal">$_</td>\n};
 998                         foreach ( keys %{$value} ) {
 999                                 my $tmp = $_;
1000                                 $flag[$exp{$tmp}] = $value->{$_};
1001                         }
1002                         foreach ( @flag ) {
1003                                 my $size = $_->{size};
1004                                 my $last = $_->{last} || ( $_->{size} eq '0 B' ? '◆' : '○' );
1005                                 my $check = $size ? qq {<span title="$size">$last</span>} : '<br>';
1006                                 $HTML .= qq {<td>$check</td>\n};
1007                         }
1008                         if ( $flag[$exp{mp4}] ) {
1009                                 s/#/＃/g;
1010                                 s/ /\+/g;
1011                                 my $img = $value->{mp4}->{img};
1012                                 $HTML  .= qq {<td><a href="rectool.pl?mode=thumb&amp;title=$img">■</a></td>\n};
1013                                 my $pre = qq {<a href="rectool.pl?mode=change&amp;mode_sub=move&amp;mode_sub2=predict&amp;title=$_">予測</a>};
1014                                 $HTML  .= qq {<td>$pre</td>\n};
1015                                 my $exe = qq {<a href="rectool.pl?mode=change&amp;mode_sub=move&amp;mode_sub2=exec&amp;title=$_">実行</a>};
1016                                 $HTML  .= qq {<td>$exe</td>\n};
1017                         }
1018                         else {
1019                                 $HTML .= qq {<td><br></td>\n<td colspan="2"><br></td>\n};
1020                         }
1021                         $HTML .= qq {</tr>\n};
1022                 }
1023                 $HTML .= qq {</table>\n};
1024
1025                 sub wanted {
1026                         return if ( !$_ );
1027                         return if ( -d $File::Find::name );
1028                         return if ( $_ eq 'Thumbs.db' );
1029                         return if ( /\.idx/ );
1030                         s/\.temp$//;
1031                         my $regexp = join '|', keys %exp;
1032                         my ( $title, $exp ) = /(.*?)\.($regexp)$/;
1033                         my ( $size, $last ) = &get_size( $File::Find::name );
1034                         my $img;
1035                         $File::Find::name =~ s/\.temp$//;
1036                         if ( !$title ) {
1037                                 $title = '_error_exp_'.$_;
1038                                 $exp   = 'log';
1039                         }
1040                         if ( $title !~ /[^0-9A-F]+/ ) {
1041                                 my $tmp = pack( 'H*', $title );
1042                                 if ( !$tmp ) {
1043                                         $title = '_error_b16_'.$_;
1044                                         $exp   = 'log';
1045                                 }
1046                                 else {
1047                                         $title = 'Base16_'.$tmp;
1048                                 }
1049                         }
1050                         if ( $_ =~ /mp4/ ) {
1051                                 my $tmp = $title;
1052                                 $tmp =~ s/#/＃/g;
1053                                 $tmp =~ s/ /\+/g;
1054                                 $img = $tmp;
1055                         }
1056                         $list{$title}->{$exp} = { 'last' => $last, 'size' => $size, 'img' => $img };
1057                 }
1058         }
1059
1060         sub simple_list {
1061                 local $path = shift;
1062                 local @list = ();
1063
1064                 File::Find::find( \&simple_wanted, $path );
1065
1066                 @list = sort @list;
1067                 foreach ( @list ) {
1068                         $HTML .= "$_<br>\n";
1069                 }
1070
1071                 sub simple_wanted {
1072                         return if ( !$_ );
1073                         return if ( -d $File::Find::name );
1074                         return if ( $_ eq 'Thumbs.db' );
1075                         my ( $size ) = &get_size( $File::Find::name );
1076                         $File::Find::name =~ s/\Q$path\E//;
1077                         push @list, $File::Find::name ."\t\t". $size;
1078                 }
1079         }
1080
1081         sub get_size {
1082                 my $file = shift;
1083                 my ( $size, $last ) = (stat( $file ))[7,9];
1084                 my @unim = ("B","KB","MB","GB","TB","PB");
1085                 my $count = 0;
1086
1087                 while($size >= 1024 ){
1088                         $count++;
1089                         $size = $size / 1024;
1090                 }
1091                 $size *= 100;
1092                 $size  = int( $size );
1093                 $size /= 100;
1094                 if ( time - $last < 10 ) {
1095                         $last = '●';
1096                 }
1097                 else {
1098                         $last = '';
1099                 }
1100                 return ( "$size $unim[$count]", $last );
1101         }
1102 }
1103
1104 if ( $mode eq 'thumb' ) {
1105         my $title = $q->param( 'title' );
1106         my $pos  = $q->param( 'pos' );
1107         my $recording = $cfg->param( 'path.recpath' );
1108         $title =~ s/\+/ /g;
1109         $title =~ s/＃/#/g;
1110
1111         print "Content-Type: image/jpeg\n\n";
1112         exec "ffmpeg -ss 300 -i '$recording/$title.mp4' -f image2 -pix_fmt jpg -vframes 1 -s 320x240 -";
1113         exit;
1114 }
1115
1116 if ( $mode eq 'check' ) {
1117 }
1118
1119 if ( $mode eq 'bravia' ) {
1120         $HTML =~ s/%HTML_TITLE_OPT%/ - Bravia/;
1121         $HTML .= qq {<div>\n};
1122         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1123         $HTML .= qq {<div>\n};
1124         $HTML .= qq {<table summary="bayestable" border=1 cellspacing=0>\n<tr>\n};
1125         $HTML .= qq {<th>ID</th>\n};
1126         $HTML .= qq {<th>チャンネル</th>\n};
1127         $HTML .= qq {<th>タイトル</th>\n};
1128         $HTML .= qq {<th><a href="rectool.pl?mode=bravia">開始時刻</a></th>\n};
1129         $HTML .= qq {<th>終了時刻</th>\n};
1130         $HTML .= qq {<th>録画時間</th>\n};
1131         $HTML .= qq {<th><a href="rectool.pl?mode=bravia&amp;order=point">ポイント</a></th>\n};
1132         $HTML .= qq {<th>予約</th>\n};
1133         $HTML .= qq {</tr>\n};
1134
1135         my $order = $q->param( 'order' );
1136         if ( $order ne 'point' ) {
1137                 $order = 'btime';
1138         }
1139         else {
1140                 $order = 'point DESC';
1141         }
1142         my $ary_ref = $dbh->selectall_arrayref(
1143                 "SELECT id, chtxt, title, btime, etime, point
1144                 FROM auto_timeline_bayes
1145                 ORDER BY $order" );
1146
1147         foreach my $line ( @{ $ary_ref } ) {
1148                 my ( $begin, $end, $diff ) = &str2readable( $line->[3], $line->[4] );
1149
1150                 $HTML .= qq {<tr align="center">\n};
1151                 $HTML .= qq {<td>$line->[0]</td>\n};
1152                 $HTML .= qq {<td>$line->[1]</td>\n};
1153                 $HTML .= qq {<td>$line->[2]</td>\n};
1154                 $HTML .= qq {<td>$begin</td>\n<td>$end</td>\n<td>$diff</td>\n};
1155                 $HTML .= qq {<td>$line->[5]</td>\n};
1156                 $HTML .= qq {<td><a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;bayesid=$line->[0]">予約</a></td>\n};
1157                 $HTML .= qq {</tr>\n};
1158         }
1159         $HTML .= qq {</table>\n};
1160         $HTML .= qq {</div>\n};
1161         $HTML .= qq {</form>\n};
1162
1163 }
1164
1165 if ( $mode eq 'proc' ) {
1166         $HTML =~ s/%HTML_TITLE_OPT%/ - Proposal/;
1167         $HTML .= qq {<div>\n};
1168         $HTML .= qq {<table summary="proctable" border=1 cellspacing=0>\n<tr>\n};
1169         $HTML .= qq {<th>タイプ</th>\n};
1170         $HTML .= qq {<th>タイトル</th>\n};
1171         $HTML .= qq {<th>予約</th>\n};
1172         $HTML .= qq {</tr>\n};
1173
1174         my $ary_ref = $dbh->selectall_arrayref(
1175                 "SELECT type, chtxt, title
1176                 FROM auto_proc " );
1177
1178         foreach my $line ( @{ $ary_ref } ) {
1179                 my $url;
1180                 $line->[3] = $q->url_encode( $line->[2] );
1181
1182                 if ( $line->[0] =~ /^auto_suggest_(dec|enc)/ ) {
1183                         $url = qq {rectool.pl?mode=confirm&amp;mode_sub=proc&amp;type=$line->[0]&amp;chtxt=$line->[1]&amp;title=$line->[3]};
1184                 }
1185                 else {
1186                         $url = qq {rectool.pl?mode=change&amp;mode_sub=proc&amp;type=$line->[0]&amp;chtxt=$line->[1]&amp;title=$line->[3]};
1187                 }
1188                 $line->[0] = $type{$line->[0]} ? $type{$line->[0]} : $line->[0];
1189                 $HTML .= qq {<tr align="center">\n};
1190                 $HTML .= qq {<td>$line->[0]</td>\n};
1191                 $HTML .= qq {<td>$line->[2]</td>\n};
1192                 $HTML .= qq {<td><a href="$url">予約</a></td>\n};
1193                 $HTML .= qq {</tr>\n};
1194         }
1195
1196         $HTML .= qq {</table>\n};
1197 }
1198
1199 if ( $mode eq 'jbk' ) {
1200         $HTML =~ s/%HTML_TITLE_OPT%/ - JBK/;
1201         $HTML .= qq {<div>\n};
1202
1203         if ( $mode_sub eq 'add' ) {
1204                 my $keyword = $q->param( 'keyword' );
1205                 $HTML .= "キーワード「$keyword」を追加しました。<br>\n";
1206                 $dbh->do(
1207                         "INSERT INTO in_auto_jbk_key ( keyword )
1208                         VALUES ( '$keyword' )"
1209                 );
1210         }
1211         elsif ( $mode_sub eq 'del' ) {
1212                 my $id = $q->param( 'id' );
1213                 my $keyword = $dbh->selectrow_array(
1214                         "SELECT keyword FROM in_auto_jbk_key
1215                         WHERE id = '$id' " );
1216                 $HTML .= "キーワード「$keyword」を削除しました。<br>\n";
1217                 $dbh->do(
1218                         "DELETE FROM in_auto_jbk_key WHERE id = '$id'"
1219                 );
1220         }
1221
1222         $HTML .= qq {<table summary="jbktable" border=1 cellspacing=0>\n<tr>\n};
1223         $HTML .= qq {<th>ID</th>\n};
1224         $HTML .= qq {<th>キーワード</th>\n};
1225         $HTML .= qq {<th>削除</th>\n};
1226         $HTML .= qq {</tr>\n};
1227
1228         my $ary_ref = $dbh->selectall_arrayref(
1229                 "SELECT id, keyword
1230                 FROM in_auto_jbk_key
1231                 ORDER BY id " );
1232
1233         foreach my $line ( @{ $ary_ref } ) {
1234                 my $url = "rectool.pl?mode=jbk&amp;mode_sub=del&amp;id=$line->[0]";
1235
1236                 $HTML .= qq {<tr align="center">\n};
1237                 $HTML .= qq {<td>$line->[0]</td>\n};
1238                 $HTML .= qq {<td>$line->[1]</td>\n};
1239                 $HTML .= qq {<td><a href="$url">削除</a></td>\n};
1240                 $HTML .= qq {</tr>\n};
1241         }
1242
1243         $HTML .= qq {</table>\n};
1244
1245         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1246         $HTML .= qq {<div>\n};
1247         $HTML .= qq {<input type="hidden" name="mode" value="jbk">\n};
1248         $HTML .= qq {<input type="hidden" name="mode_sub" value="add">\n};
1249         $HTML .= qq {<input name="keyword" type="text">\n};
1250         $HTML .= qq {<input type="submit" value="追加">\n</div>\n</form>\n<br>\n};
1251
1252         $HTML .= qq {<table summary="jbkrestable" border=1 cellspacing=0>\n<tr>\n};
1253         $HTML .= qq {<th>ID</th>\n};
1254         $HTML .= qq {<th>チャンネル</th>\n};
1255         $HTML .= qq {<th>タイトル</th>\n};
1256         $HTML .= qq {<th>開始時刻</th>\n};
1257         $HTML .= qq {<th>終了時刻</th>\n};
1258         $HTML .= qq {<th>録画時間</th>\n};
1259         $HTML .= qq {<th>予約</th>\n};
1260         $HTML .= qq {</tr>\n};
1261
1262         my $ary_ref = $dbh->selectall_arrayref(
1263                 "SELECT id, chtxt, title, btime, etime
1264                 FROM auto_timeline_keyword " );
1265
1266         foreach my $line ( @{ $ary_ref } ) {
1267                 my ( $begin, $end, $diff ) = &str2readable( $line->[3], $line->[4] );
1268                 $line->[3] =~ s/(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/$1$2$3$4$5$6/;
1269                 $line->[4] =~ s/(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/$1$2$3$4$5$6/;
1270                 my $url = qq "rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chtxt=$line->[1]&amp;start=$line->[3]&amp;stop=$line->[4]";
1271
1272                 $HTML .= qq {<tr align="center">\n};
1273                 $HTML .= qq {<td>$line->[0]</td>\n};
1274                 $HTML .= qq {<td>$line->[1]</td>\n};
1275                 $HTML .= qq {<td>$line->[2]</td>\n};
1276                 $HTML .= qq {<td>$begin</td>\n};
1277                 $HTML .= qq {<td>$end</td>\n};
1278                 $HTML .= qq {<td>$diff</td>\n};
1279                 $HTML .= qq {<td><a href="$url">予約</a></td>\n};
1280                 $HTML .= qq {</tr>\n};
1281         }
1282
1283         $HTML .= qq {</table>\n};
1284
1285 }
1286
1287 if ( $mode eq 'expert' ) {
1288         my $ary_ref;
1289
1290         $HTML =~ s/%HTML_TITLE_OPT%/ - Expert/;
1291         $HTML .= qq {<div>\n};
1292
1293         if ( $mode_sub eq 'reget' ) {
1294                 my $bctype = $q->param( 'bctype' );
1295                 my ( $ontv, $chname ) = $dbh->selectrow_array(
1296                         "SELECT ontv, chname FROM epg_ch
1297                         WHERE bctype = '$bctype' " );
1298                 $HTML .= "Update for $chname ( ontv: $ontv ) has been reserved.<br>\n";
1299                 $dbh->do( "UPDATE epg_ch SET status = '2' WHERE ontv = '$ontv' " );
1300                 goto end;
1301         }
1302
1303
1304         $ary_ref = $dbh->selectcol_arrayref(
1305                 "SELECT DISTINCT category FROM epg_timeline"
1306         );
1307         # 一時的
1308         #       my @category = map { $category{$_} . $_ } sort keys %category;
1309         my @category = sort values %category;
1310         $HTML .= qq {<hr>\n番組表のカテゴリ一覧と内蔵の一覧の合致を確認中...\n};
1311         if ( List::Compare->new( $ary_ref, \@category )->get_symdiff ) {
1312                 $HTML .= qq {一致しません<br>\n};
1313                 $HTML .= qq {番組表：@{$ary_ref}<br>\n内蔵：@category<br>\n};
1314         }
1315         else {
1316                 $HTML .= qq {一致しました<br>\n};
1317         }
1318
1319         my @ary = $dbh->selectrow_array( "SELECT terec, bscsrec, b252ts, ts2avi FROM in_status" );
1320         $HTML .= qq {<hr>\n地上波録画数：$ary[0]\n衛星波録画数：$ary[1]\n解読数：$ary[2]\n縁故数：$ary[3]\n<br>\n};
1321
1322         use List::Compare;
1323         $ary_ref = $dbh->selectall_arrayref( "SELECT chname, chtxt FROM epg_ch" );
1324         my $prev;
1325         $HTML .= "<hr>\n番組表の欠落<br>\n";
1326         foreach my $line ( @{$ary_ref} ) {
1327                 my $ary_ref = $dbh->selectall_arrayref(
1328                         "SELECT start, stop, title FROM epg_timeline WHERE channel = '$line->[1]' ORDER BY start"
1329                 );
1330                 my $error;
1331                 my @program_old = ( '', $ary_ref->[0]->[0] );
1332                 my $program_old = \@program_old;
1333
1334                 foreach my $program_new ( @{$ary_ref} ) {
1335                         if ( $program_old->[1] ne $program_new->[0] &&
1336                                 $program_old->[2] !~ /クロ?ジング|クロージング|エンディング|休止|ミッドナイトプレゼント/ &&
1337                                 $program_new->[2] !~ /オープニング|ウィークリー・インフォメーション|モーニングプレゼント/ &&
1338                                 ( str2datetime( $program_new->[0] ) - str2datetime( $program_old->[1] ) )->delta_minutes > 30 ) {
1339                                 $program_old->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1340                                 $program_new->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1341                                 $error .= qq{    $program_old->[2]    $program_old->[1]\n    ?  $program_new->[2]    $program_new->[0]\n};
1342                         }
1343                         $program_old = $program_new;
1344                 }
1345                 $HTML .= qq {<pre>\n$line->[0]\n$error</pre>\n} if ( $error );
1346                 }
1347
1348         $ary_ref = $dbh->selectall_arrayref(
1349                 "SELECT chname, chtxt, ontv, bctype, ch, csch, updatetime, status
1350                 FROM epg_ch
1351                 ORDER BY bctype " );
1352         $HTML .= qq {<hr>\n番組表の更新状況<br>\n};
1353         $HTML .= qq {<table summary="channeltable" border=1 cellspacing=0>\n<tr>\n};
1354         $HTML .= qq {<th>チャンネル名</th>\n};
1355         $HTML .= qq {<th>チャンネルコード</th>\n};
1356         $HTML .= qq {<th>ontvコード</th>\n};
1357         $HTML .= qq {<th>タイプ</th>\n};
1358         $HTML .= qq {<th>ch</th>\n};
1359         $HTML .= qq {<th>csch</th>\n};
1360         $HTML .= qq {<th>最終更新時刻</th>\n};
1361         $HTML .= qq {<th>状態</th>\n};
1362         $HTML .= qq {</tr>\n};
1363         foreach my $status ( @{$ary_ref} ) {
1364                 $HTML .= qq {<tr>\n};
1365                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1366                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1367                 $HTML .= qq {</tr>\n};
1368         }
1369         $HTML .= qq {</table>\n};
1370
1371         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1372         $HTML .= qq {<div>\n};
1373         $HTML .= qq {番組表を再取得する\n};
1374         $HTML .= qq {<input type="hidden" name="mode" value="expert">\n};
1375         $HTML .= qq {<input type="hidden" name="mode_sub" value="reget">\n};
1376         $HTML .= qq {<select name="bctype">\n};
1377         $ary_ref = $dbh->selectall_arrayref(
1378                 "SELECT chname, bctype
1379                 FROM epg_ch WHERE bctype NOT LIKE '_s%' "
1380         );
1381         foreach my $line ( @{$ary_ref} ) {
1382                 $HTML .= qq {<option value="$line->[1]">$line->[0]</option>\n};
1383         }
1384         $HTML .= qq {<option value="bs">BS</option>\n};
1385         $HTML .= qq {<option value="cs1">CS1</option>\n};
1386         $HTML .= qq {<option value="cs2">CS2</option>\n};
1387         $HTML .= qq {</select>\n};
1388         $HTML .= qq {<input type="submit" value="実行">\n</div>\n</form>\n};
1389
1390
1391
1392         $ary_ref = $dbh->selectall_arrayref(
1393                 "SELECT id, type, chtxt, title, btime, etime, deltaday, deltatime
1394                 FROM timeline
1395                 ORDER BY id ");
1396         $HTML .= qq {<hr>\n予約表<br>\n};
1397         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
1398         $HTML .= qq {<th>ID</th>\n};
1399         $HTML .= qq {<th>type</th>\n};
1400         $HTML .= qq {<th>chtxt</th>\n};
1401         $HTML .= qq {<th>title</th>\n};
1402         $HTML .= qq {<th>btime</th>\n};
1403         $HTML .= qq {<th>etime</th>\n};
1404         $HTML .= qq {<th>deltaday</th>\n};
1405         $HTML .= qq {<th>deltatime</th>\n};
1406         $HTML .= qq {</tr>\n};
1407         foreach my $status ( @{$ary_ref} ) {
1408                 $HTML .= qq {<tr>\n};
1409                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1410                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1411                 $HTML .= qq {</tr>\n};
1412         }
1413         $HTML .= qq {</table>\n};
1414 }
1415
1416 if ( $mode eq 'help' ) {
1417         $HTML =~ s/%HTML_TITLE_OPT%/ - Help/;
1418         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1419         $HTML .= qq {<div>\n};
1420         $HTML .= qq {ヘルプ\n};
1421 }
1422
1423 if ( $mode eq 'test' ) {
1424         $HTML =~ s/%HTML_TITLE_OPT%/ - Test/;
1425         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1426         $HTML .= qq {<div>\n};
1427
1428         require Data::Dumper;
1429         require Perl6::Slurp;
1430         $tmp = Perl6::Slurp::slurp( 'config.ini' );
1431         $tmp =~ s/\n/<br>\n/gs;
1432         $HTML .= $tmp;
1433
1434         # $HTML .= Dumper( $ary_ref );
1435 }
1436
1437 if ( !$mode ) {
1438         &draw_form();
1439         $HTML =~ s/%HTML_TITLE_OPT%/ - Top/;
1440         $HTML .= qq {Welcome to Rec10!<br>\n};
1441         goto end;
1442 }
1443
1444
1445 end:
1446 #<div style="float: right">
1447 $HTML .= <<EOM;
1448 </div>
1449 </body>
1450 </html>
1451 EOM
1452
1453 #<div align="center">
1454 #$HTML_ADV = $HTML_ADV_IMG . $HTML_ADV_TEXT if ( !$HTML_ADV );
1455 $HTML_HEADER = qq {<div style="text-align: center">\n$HTML_ADV\n</div>\n};
1456
1457 &draw_menu();
1458 $HTML =~ s/%HTML_TITLE_OPT%//;
1459 $HTML =~ s/%REFRESH%//;
1460 $HTML =~ s/%SCRIPT%//;
1461 $HTML =~ s/%CSS%//;
1462 $HTML =~ s/%HTML_HEADER%/$HTML_HEADER/;
1463
1464 print $HTTP_HEADER;
1465 print $HTML;
1466
1467 sub draw_menu {
1468         $hires = Time::HiRes::time() - $hires;
1469         $last_modified = localtime((stat 'rectool.pl')[9]);
1470
1471         $HTML_HEADER .= qq {<div>\n};
1472         $HTML_HEADER .= qq {<span style="float: right; font-size: 8px">Last-Modified: $last_modified<br>Time-Elasped: $hires秒</span>\n};
1473         $HTML_HEADER .= qq {<span style="float: left">\n};
1474         $HTML_HEADER .= qq {<a href="rectool.pl">トップ</a>\n};
1475         $HTML_HEADER .= qq {<a href="rectool.pl?mode=schedule">予約確認</a>\n};
1476         $HTML_HEADER .= qq {<a href="rectool.pl?mode=graph">予約状況(画像版)</a>\n};
1477         $HTML_HEADER .= qq {<a href="rectool.pl?mode=list">録画一覧</a>\n};
1478         $HTML_HEADER .= qq {<a href="rectool.pl?mode=bravia">おまかせ</a>\n};
1479         $HTML_HEADER .= qq {<a href="rectool.pl?mode=expert">玄人仕様</a>\n};
1480         $HTML_HEADER .= qq {<a href="rectool.pl?mode=proc">復旧支援</a>\n};
1481         $HTML_HEADER .= qq {<a href="rectool.pl?mode=jbk">地引</a>\n};
1482         $HTML_HEADER .= qq {<a href="../rec10web/rec10web.py">新規予約</a>\n};
1483         $HTML_HEADER .= qq {<a href="rectool.pl?mode=edit">新規予約2</a>\n};
1484         $HTML_HEADER .= qq {</span>\n};
1485         $HTML_HEADER .= qq {<hr style="clear: both; background-color: grey; height: 4px">\n};
1486         $HTML_HEADER .= qq {</div>\n};
1487 }
1488
1489 sub draw_form {
1490         $chname = $q->param( 'chname' );
1491         $key    = $q->param( 'key' );
1492         $ontv = $dbh->selectrow_array("SELECT ontv FROM epg_ch WHERE chname = '$chname' ");
1493
1494         $HTML .= qq {<div style="float: left">\n};
1495         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1496         $HTML .= qq {<div>\n};
1497         $HTML .= qq {<input type="hidden" name="mode" value="program">\n};
1498
1499         # チャンネル指定
1500         $HTML .= qq {<select name="chname">\n<option value="" selected>無指定</option>\n};
1501         $ary_ref = $dbh->selectcol_arrayref(
1502                 "SELECT chname FROM epg_ch"
1503         );
1504         foreach my $line ( @{$ary_ref} ) {
1505                 if ( $line eq $chname ) {
1506                         $HTML .= qq {<option value="$line" selected>$line</option>\n};
1507                 }
1508                 else {
1509                         $HTML .= qq {<option value="$line">$line</option>\n};
1510                 }
1511         }
1512         $HTML .= qq {</select>\n};
1513
1514         # 日付指定
1515         $HTML .= qq {<select name="date">\n<option value="" selected>無指定</option>\n};
1516         $ary_ref = $dbh->selectcol_arrayref(
1517                 "SELECT DISTINCT SUBSTRING(start, 1, 8) FROM epg_timeline ORDER BY start"
1518         );
1519         $date_sel = $q->param( 'date' );
1520         foreach my $date ( @{ $ary_ref } ) {
1521                 my @date = $date =~ /(.{4})(.{2})(.{2})/;
1522                 $date_prt = "$date[1]/$date[2]";
1523
1524                 if ( $date eq $date_sel ) {
1525                         $HTML .= qq {<option value="$date" selected>$date_prt</option>\n};
1526                 }
1527                 else {
1528                         $HTML .= qq {<option value="$date">$date_prt</option>\n};
1529                 }
1530         }
1531         $HTML .= qq {</select>\n};
1532
1533         # カテゴリ指定
1534         $HTML .= qq {<select name="category">\n<option value="" selected>無指定</option>\n};
1535         $category_sel = $q->param( 'category' );
1536         foreach my $category ( keys %category ) {
1537                 if ( $category eq $category_sel ) {
1538                         $HTML .= qq {<option value="$category" selected>$category{$category}</option>\n};
1539                 }
1540                 else {
1541                         $HTML .= qq {<option value="$category">$category{$category}</option>\n};
1542                 }
1543         }
1544         $HTML .= qq {</select>\n};
1545
1546         # キーワード指定
1547         $HTML .= qq {<input name="key" type="text" value="$key" style="width:200px">\n};
1548
1549         # フォーム描画
1550         $HTML .= qq {<input type="submit" value="更新">\n</div>\n</form>\n};
1551 }
1552
1553 sub parse_program {
1554         $chname  = $q->param( 'chname' );
1555         $chtxt   = $q->param( 'chtxt' );
1556         $start   = $q->param( 'start' );
1557         $stop    = $q->param( 'stop' );
1558         $bayesid = $q->param( 'bayesid' );
1559         $id      = $q->param( 'id' );
1560
1561         if ( $chname ) {
1562                 $ontv     = $dbh->selectrow_array("SELECT ontv   FROM epg_ch WHERE chname = '$chname'");
1563                 $chtxt    = $dbh->selectrow_array("SELECT chtxt  FROM epg_ch WHERE ontv   = '$ontv'");
1564         }
1565         elsif ( $chtxt ) {
1566                 $ontv     = $dbh->selectrow_array("SELECT ontv   FROM epg_ch WHERE chtxt  = '$chtxt'");
1567                 $chname   = $dbh->selectrow_array("SELECT chname FROM epg_ch WHERE ontv   = '$ontv'");
1568         }
1569         $title    = $dbh->selectrow_array("SELECT title    FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' ");
1570         $desc     = $dbh->selectrow_array("SELECT exp      FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' ");
1571         $longdesc = $dbh->selectrow_array("SELECT longexp  FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' ");
1572         $category = $dbh->selectrow_array("SELECT category FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' ");
1573         $bctype   = $dbh->selectrow_array("SELECT bctype   FROM epg_ch       WHERE ontv    = '$ontv'");
1574
1575         if ( $bayesid ) {
1576                 ( $chtxt, $title, $begin, $end ) = $dbh->selectrow_array(
1577                         "SELECT chtxt, title, btime, etime FROM auto_timeline_bayes WHERE id = '$bayesid' "
1578                 );
1579                 ( $ontv, $chname, $bctype ) = $dbh->selectrow_array(
1580                         "SELECT ontv, chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
1581                 );
1582                 $start = str2datetime( $begin )->strftime( '%Y%m%d%H%M%S' );
1583                 $stop  = str2datetime( $end   )->strftime( '%Y%m%d%H%M%S' );
1584                 ( $desc, $longdesc, $category ) = $dbh->selectrow_array(
1585                         "SELECT exp, longexp, category FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' "
1586                 );
1587         }
1588         if ( $id ) {
1589                 ( $type, $chtxt, $title, $begin, $end, $deltaday, $deltatime, $opt ) = $dbh->selectrow_array(
1590                         "SELECT type, chtxt, title, btime, etime, deltaday, deltatime, opt
1591                         FROM timeline WHERE id = '$id' "
1592                 );
1593                 ( $ontv, $chname, $bctype ) = $dbh->selectrow_array(
1594                         "SELECT ontv, chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
1595                 );
1596                 $start = str2datetime( $begin )->strftime( '%Y%m%d%H%M%S' );
1597                 $stop  = str2datetime( $end   )->strftime( '%Y%m%d%H%M%S' );
1598                 ( $desc, $longdesc, $category ) = $dbh->selectrow_array(
1599                         "SELECT exp, longexp, category FROM epg_timeline WHERE channel = '$ontv' AND start = '$start' AND stop = '$stop' "
1600                 );
1601         }
1602         if ( $bctype =~ /.s/ ) {
1603                 $bctype_sql = '_s%';
1604         }
1605         elsif ( $bctype =~ /te/ ) {
1606                 $bctype_sql = 'te%';
1607         }
1608         @start = $start =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
1609         @stop  = $stop  =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
1610         $begin = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @start, '00' );
1611         $end   = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @stop , '00' );
1612 }
1613
1614 sub check_error {
1615         my $is_error;
1616         my $is_same = $dbh->selectrow_array(
1617                 "SELECT COUNT(*) FROM timeline WHERE chtxt = '$chtxt' AND btime = '$begin' AND etime = '$end'"
1618         );
1619         my @overlap = &get_overlap();
1620
1621         if ( $is_same ) {
1622                 $HTML .= "同一の番組が既に存在します。<br>\n";
1623                 $is_error = 1;
1624         }
1625         elsif ( $overlap[0] >= 2 ) {
1626                 $HTML .= "時間が被る番組が既に2個存在します。<br>\n";
1627                 $HTML .= $overlap[1];
1628                 $is_error = 2;
1629         }
1630         else {
1631                 $is_error = 0;
1632         }
1633         return $is_error;
1634 }
1635
1636 sub get_overlap {
1637         require List::Util;
1638
1639         my $ary_ref = $dbh->selectall_arrayref(
1640                 "SELECT btime, etime, title
1641                 FROM timeline
1642                 INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
1643                 WHERE bctype LIKE '$bctype_sql' AND type IN $type_user_made
1644                 AND btime < '$end'
1645                 AND etime > '$begin'
1646                 "
1647         );
1648
1649         my %overlap;
1650         my $overlap = $max = 0;
1651         my $str;
1652         foreach my $prg ( @{ $ary_ref } ) {
1653                 $str .= "$prg->[0] ? $prg->[1] : $prg->[2]<br>\n";
1654                 $overlap{$prg->[0]} += 1;
1655                 $overlap{$prg->[1]} -= 1;
1656         }
1657         foreach my $key ( sort keys %overlap ) {
1658                 $overlap += $overlap{$key};
1659                 $max = List::Util::max( $max, $overlap );
1660         }
1661         if ( wantarray ) {
1662                 return ( $max, $str );
1663         }
1664         else {
1665                 return $max;
1666         }
1667 }
1668
1669 sub strisjoined {
1670         my $str = shift;
1671
1672         return $str =~ /.{4}-.{2}-.{2} .{2}:.{2}:.{2}/ ? 0 : 1;
1673 }
1674
1675 sub str2datetime {
1676         my $str    = shift;
1677         my @time;
1678
1679         if ( strisjoined( $str ) ) {
1680                 @time = $str =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
1681         }
1682         else {
1683                 @time = $str =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
1684         }
1685         return DateTime->new(
1686                 year   => $time[0], month     => $time[1], day    => $time[2],
1687                 hour   => $time[3], minute    => $time[4], second => $time[5],
1688                 locale => 'ja_JP' , time_zone => $tz
1689         );
1690 }
1691
1692 sub str2dayname {
1693         my  $str = shift;
1694         our %day_name_cache;
1695
1696         if ( !$day_name_cache{$str} ) {
1697                 $day_name_cache{$str} = str2datetime( $str )->day_name;
1698         }
1699         return $day_name_cache{$str};
1700 }
1701
1702 sub str2readable {
1703         my $begin = shift;
1704         my $end   = shift;
1705
1706         my $dt_begin = &str2datetime( $begin );
1707         my $dt_end   = &str2datetime( $end );
1708
1709         my $str_begin = $dt_begin->strftime( '%m/%d(%a) %H:%M' );
1710         my $str_end   = $dt_end  ->strftime( $dt_begin->day == $dt_end->day ? '%H:%M' : '翌 %H:%M' );
1711         utf8::encode( $str_begin );
1712
1713         my ( $sec, $min, $hour );
1714         $sec  = $dt_end->epoch - $dt_begin->epoch;
1715         $min  = int( $sec / 60 );
1716         $sec  = $sec - $min * 60;
1717         $hour = int( $min / 60 );
1718         $min  = $min - $hour * 60;
1719         my $str_diff = '';
1720         $str_diff .= $hour . '時間' if ( $hour );
1721         $str_diff .= $min  . '分'   if ( $min );
1722         $str_diff .= $sec  . '秒'   if ( $sec );
1723
1724         return ( $str_begin, $str_end, $str_diff );
1725 }
1726
1727 sub sqlgetsuggested {
1728         require Encode;
1729         require Text::Ngram;
1730
1731         my ( $btime, $etime ) = @_;
1732
1733         $btime_bgn = $btime->clone->subtract( hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
1734         $btime_end = $btime->clone->add(      hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
1735         $etime_bgn = $etime->clone->subtract( hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
1736         $etime_end = $etime->clone->add(      hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
1737
1738         my $ontv = $dbh->selectrow_array( "SELECT ontv FROM epg_ch WHERE chtxt = '$chtxt' " );
1739         $ary_ref = $dbh->selectall_arrayref(
1740                 "SELECT start, stop, title, exp
1741                 FROM epg_timeline
1742                 WHERE channel = '$ontv'
1743                 AND start BETWEEN '$btime_bgn' AND '$btime_end'
1744                 AND stop  BETWEEN '$etime_bgn' AND '$etime_end' "
1745         );
1746
1747         my %hash;
1748         my $hash_r = Text::Ngram::ngram_counts( Encode::decode_utf8( $title ), 2 ); # bi-gram
1749         foreach my $program ( @{$ary_ref} ) {
1750                 my $hash_k = Text::Ngram::ngram_counts( Encode::decode_utf8( $program->[2] ), 2 );
1751                 my $point;
1752                 map $point += $hash_k->{$_}, keys %{$hash_r};
1753                 push @{$hash{$point}}, $program if ( $point );
1754         }
1755
1756         return %hash;
1757 }