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 warnings;
  13 use DBI;
  14 use Time::Piece;
  15 use Time::Seconds;
  16 use Date::Simple;
  17 use DateTime;
  18 use CGI;
  19 use MIME::Base64;
  20 use Config::Simple;
  21 use Time::HiRes;
  22 use Data::Dumper;
  23 use Tie::IxHash;
  24 use Perl6::Slurp;
  25 use Sort::Naturally;
  26 use Algorithm::Diff qw(LCS);
  27 #require SVG Time::Simple XML::Atom Encode Text::Ngram List::Compare List::Util
  28 use utf8;
  29 #%DB::packages = ( 'main' => 1 );
  30
  31
  32 ################ バージョン定義 ################
  33
  34
  35 my $rectool_version = 100;
  36
  37
  38 ################ 初期化ここから ################
  39
  40
  41 my $tz = DateTime::TimeZone->new( name => 'local' );
  42 my $hires = Time::HiRes::time();
  43
  44 my $cfg = new Config::Simple;
  45 if ( -e 'rec10.conf' ) {
  46         $cfg->read( 'rec10.conf' );
  47 }
  48 elsif ( -e '/etc/rec10.conf' ) {
  49         $cfg->read( '/etc/rec10.conf' );
  50 }
  51 else {
  52         die 'rec10.confが見つかりません。';
  53 }
  54
  55 my $sql = $cfg->param( 'db.db' );
  56
  57 if ( $sql eq 'MySQL' ) {
  58         my $name = $cfg->param( 'db.mysql_dbname' );
  59         my $host = $cfg->param( 'db.mysql_host' );
  60         my $port = $cfg->param( 'db.mysql_port' );
  61         my $user = $cfg->param( 'db.mysql_user' );
  62         my $pass = $cfg->param( 'db.mysql_passwd' );
  63         $dbh = DBI->connect("dbi:mysql:$name:$host:$port", $user, $pass, {
  64                 AutoCommit => 1,
  65                 RaiseError => 1,
  66                 mysql_enable_utf8 => 1, # only availavle for MySQL
  67         });
  68         $dbh->do( 'SET NAMES utf8' );
  69 }
  70
  71 my $rec10_version = eval {
  72         $dbh->selectrow_array( "SELECT version FROM in_status " );
  73 };
  74
  75 my $HTML;
  76
  77 $HTTP_HEADER = "Content-Type: text/html\n\n";
  78 $HTML .= <<EOM;
  79 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
  80 <html lang="ja">
  81 <head>
  82 <title>Rec10%HTML_TITLE_OPT%</title>
  83 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
  84 <meta http-equiv="Content-Script-Type" content="text/javascript">
  85 <meta http-equiv="Content-Style-Type" content="text/css">
  86 <meta name="robots" content="noindex,nofollow,noarchive">
  87 <link rev="made" href="Rea10">
  88 <link rel="alternate" type="application/atom+xml" title= "Rec10 Atom Feed" href="./rectool.pl?mode=atom">
  89 %REFRESH%
  90 %SCRIPT%
  91 %CSS%
  92 </head>
  93 <body>
  94 %HTML_HEADER%
  95 EOM
  96
  97 my ( $user, $pass, $auth );
  98 ( $user, $pass ) = eval {
  99         $dbh->selectrow_array( "SELECT webuser, webpass FROM in_settings " );
 100 };
 101
 102 if ( $user and $pass ) {
 103         if ( $ENV{'HTTP_AUTHORIZATION'} ) {
 104                 my ( $base64 ) = $ENV{'HTTP_AUTHORIZATION'} =~ /Basic\s(.*)/;
 105                 if ( $base64 eq encode_base64( "$user:$pass" ) ) {
 106                         $auth = 1;
 107                 }
 108                 else {
 109                         $auth = 0;
 110                 }
 111         }
 112         else {
 113                 $auth = 0;
 114         }
 115 }
 116 else {
 117         $auth = 1;
 118 }
 119
 120 if ( !$auth ) {
 121         my ( $base64 ) = $ENV{'REMOTE_USER'} =~ /Basic (.*)/;
 122         $HTTP_HEADER = qq {Status: 401 Authorization Required\nWWW-Authenticate: Basic realm="Protected Rec10 $ENV{'HTTP_AUTHORIZATION'}"\n} . $HTTP_HEADER;
 123         goto end;
 124 }
 125
 126 if ( $rec10_version != $rectool_version ) {
 127         $HTML .= qq {<div style="font-size: 200%; font-weight: bold; color: red">\n};
 128
 129         if ( $rec10_version > $rectool_version ) {
 130                 $HTML .= qq {Rec10本体のバージョンが新しいため、実行できません。<br>\n};
 131                 $HTML .= qq {rectoolのバージョンアップを行ってください。<br>\n};
 132         }
 133
 134         if ( $rec10_version < $rectool_version ) {
 135                 $HTML .= qq {Rec10本体のバージョンが古いため、実行できません。<br>\n};
 136                 $HTML .= qq {Rec10のバージョンアップを行ってください。<br>\n};
 137         }
 138
 139         $HTML .= qq {Rec10のバージョンは$rec10_version 、rectoolのバージョンは$rectool_version です。<br>\n};
 140         $HTML .= qq {<a href="http://sourceforge.jp/projects/rec10/">公式ページ</a>\n};
 141         goto end;
 142 }
 143
 144 $q = new CGI;
 145 %params = $q->Vars;
 146 $mode = $params{ 'mode' };
 147 $mode_sub = $params{ 'mode_sub' };
 148
 149 ################ %chtxt_chnameの準備 ################
 150
 151 my %chtxt_chname;
 152 my %chtxt_0_chname;
 153 tie %chtxt_0_chname, 'Tie::IxHash';
 154
 155 my $ary_ref = $dbh->selectall_arrayref(
 156         "SELECT chtxt, chname, ch, bctype FROM epg_ch
 157         WHERE visible = 1"
 158 );
 159
 160 %chtxt_chname = map { $_->[0], $_->[1] } @{$ary_ref};
 161
 162 # NHK BS 1/2/hiをBS/CSから除外(101-103) - by 2011/04
 163 # te: 地上波、BSのNHK以外
 164 # bc: BSのNHK、CS
 165 my @te_ary = grep $_->[0]=~ /^\d|BS_(?!10[1-3])/, @{$ary_ref};
 166 my @bc_ary = grep $_->[0]!~ /^\d|BS_(?!10[1-3])/, @{$ary_ref};
 167
 168 # teの操作(まとめる)
 169 foreach my $line ( @te_ary ) {
 170         # te xx_yyyy(chtxt) -> xx(ch)
 171         if ( $line->[3] =~ /te/ ) {
 172                 push @{ $chtxt_0_chname{        $line->[2] . '_0'} }, $line->[1];
 173         }
 174         else {
 175                 push @{ $chtxt_0_chname{'BS_' . $line->[2]       } }, $line->[1];
 176         }
 177 }
 178 foreach my $key ( keys %chtxt_0_chname ) {
 179         my @chname = @{ $chtxt_0_chname{$key} };
 180         if ( @chname >= 2 ) {
 181                 # 2つ以上ある場合
 182                 my @tmp = map { my @ary = split //, $_; \@ary } @chname;
 183                 # 1つ目と2つ目のみ比較
 184                 # FIXME: すべてを比較するべき
 185                 $chtxt_0_chname{$key} = join '', LCS( $tmp[0], $tmp[1] );
 186         }
 187         else {
 188                 # 1つしかない場合
 189                 $chtxt_0_chname{$key} = $chname[0];
 190         }
 191 }
 192
 193 # bs/csの操作(そのまま)
 194 foreach my $line ( @bc_ary ) {
 195         $chtxt_0_chname{$line->[0]} = $line->[1];
 196 }
 197 undef $ary_ref;
 198
 199
 200 ################ 定数宣言 ################
 201
 202
 203 tie %type, 'Tie::IxHash';
 204 %type = (
 205         'search_everyday'          => '隔日検索',
 206         'search_today'             => '当日検索',
 207         'reserve_flexible'         => '浮動予約',
 208         'reserve_fixed'            => '確定予約',
 209
 210         'reserve_running'          => '録画途中',
 211
 212         'convert_b25_ts'           => '解読予約',
 213         'convert_b25_ts_running'   => '解読途中',
 214         'convert_b25_ts_miss'      => '解読失敗',
 215
 216         'convert_ts_mp4'           => '縁故予約',
 217         'convert_ts_mp4_running'   => '縁故於鯖',
 218         'convert_ts_mp4_network'   => '縁故於網',
 219         'convert_ts_mp4_finished'  => '縁故完了',
 220
 221         'convert_avi_mkv'          => '変換旧露',
 222         'convert_avi_mp4'          => '変換旧四',
 223         'convert_mkv_mp4'          => '変換露四',
 224         'convert_mkv_mp4_runnings' => '換途露四',
 225
 226         'auto_suggest_dec'         => '予測解読',
 227         'auto_suggest_enc'         => '予測縁故',
 228         'auto_suggest_avi2fp'      => '予測旧四',
 229         'auto_suggest_ap2fp'       => '予測露四',
 230
 231         'move_end'                 => '移動完了',
 232 );
 233
 234 %type_suggest = (
 235         'auto_suggest_dec'    => 'convert_b25_ts',
 236         'auto_suggest_enc'    => 'convert_ts_mp4',
 237         'auto_suggest_avi2fp' => 'convert_avi_mkv',
 238         'auto_suggest_ap2fp'  => 'convert_mp4_mkv',
 239 );
 240
 241 %color = (
 242         'search_everyday'        => '#8B008B',
 243         'search_today'           => '#8B008B',
 244         'reserve_flexible'       => '#4169E1',
 245         'reserve_fixed'          => '#4169E1',
 246         'reserve_running'        => '#FF8C00',
 247         'convert_b25_ts'         => '#CD5C5C',
 248         'convert_b25_ts_running' => '#DC143C',
 249         'convert_ts_mp4'         => '#32CD32',
 250         'convert_ts_mp4_running' => '#2E8B57',
 251         'convert_ts_mp4_network' => '#808000',
 252
 253         'other'                  => '#A0A0A0',
 254 );
 255
 256 $type_user_made = "( 'search_everyday', 'search_today', 'reserve_flexible', 'reserve_fixed', 'reserve_running' )";
 257
 258 %category = (
 259         'etc'         => 'その他',
 260         'news'        => 'ニュース・報道',
 261         'variety'     => 'バラエティ',
 262         'anime'       => 'アニメ・特撮',
 263         'information' => '情報',
 264         'drama'       => 'ドラマ',
 265         'sports'      => 'スポーツ',
 266         'music'       => '音楽',
 267         'cinema'      => '映画',
 268 );
 269
 270
 271 ################ 初期化ここまで ################
 272
 273
 274 ################ mode=schedule ################
 275
 276 if ( $mode eq 'schedule' ) {
 277
 278         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer/;
 279         #$HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
 280         $css = <<EOM;
 281                 <style type="text/css">
 282                 td {
 283                         white-space: nowrap;
 284                 }
 285                 </style>
 286 EOM
 287         $css =~ s/^\t{2}//gm;
 288         $HTML =~ s/%CSS%/$css/;
 289
 290         my $order = $params{ 'order' };
 291         my $extra = $params{ 'extra' };
 292         if ( $order ne 'id' ) {
 293                 $order = 'btime';
 294         }
 295         $reverse_extra = $extra            ? '' : '&amp;extra=1';
 296         $forward_order = $order eq 'btime' ? '' : '&amp;order=id';
 297
 298         my $ary_ref = $dbh->selectall_arrayref(
 299                 "SELECT id, type, timeline.chtxt, epg_ch.chname, title, btime, etime, opt, deltaday, deltatime,
 300                 epgtitle, epgbtime, epgetime, epgexp, epgduplicate, epgchange, counter
 301                 FROM timeline
 302                 LEFT OUTER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 303                 ORDER BY $order"
 304                 , {Slice=>{}});
 305
 306         $HTML .= qq {<div style="font-size: 80%; float: left">\n};
 307         $HTML .= qq {<form method="get" action="rectool.pl">\n};
 308         $HTML .= qq {<div>\n};
 309         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 310         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
 311         $HTML .= qq {<th><a href="rectool.pl?mode=schedule$forward_order$reverse_extra">■</a></th>\n};
 312         $HTML .= qq {<th><a href="rectool.pl?mode=schedule&amp;order=id">ID</a></th>\n};
 313         $HTML .= qq {<th>タイプ</th>\n};
 314         $HTML .= qq {<th>チャンネル</th>\n};
 315         $HTML .= qq {<th>タイトル</th>\n};
 316         $HTML .= qq {<th><a href="rectool.pl?mode=schedule">開始時刻</a></th>\n};
 317         $HTML .= qq {<th>終了時刻</th>\n};
 318         $HTML .= qq {<th>録画時間</th>\n};
 319         $HTML .= qq {<th>オプション</th>\n};
 320         $HTML .= qq {<th>dd</th>\n};
 321         $HTML .= qq {<th>dt</th>\n};
 322         $HTML .= qq {<th>残り</th>\n};
 323         $HTML .= qq {</tr>\n};
 324         foreach my $line ( @{ $ary_ref } ) {
 325
 326                 $type = $type{$line->{type}} || $line->{type};
 327                 if    ( $line->{type} =~ /^search/ ) {
 328                         $type = qq {<span style="color: #8B008B">$type</span>};
 329                         $line->{deltaday} = qq {<span style="color: #FF0000">空</span>} if ( !$line->{deltaday} && $line->{type} eq 'search_everyday' );
 330                         $line->{deltatime} = qq {<span style="color: #FF0000">空</span>} if ( !$line->{deltatime} );
 331                 }
 332                 else {
 333                         my $color = $color{$line->{type}} ? $color{$line->{type}} : $color{'other'};
 334                         $type = qq {<span style="color: $color">$type</span>};
 335                 }
 336                 # 地上波の場合、xx_yyyをxx_0に置換する
 337                 ( $line->{chtxt_0} = $line->{chtxt} ) =~ s/(\d+)_/$1_0/;
 338                 # chnameが無いとき(移動縁故など)、chtxtを代わりに使う
 339                 $line->{chname} =
 340                         $line->{chname} ||
 341                         $chtxt_0_chname{$line->{chtxt}} ||
 342                         $chtxt_0_chname{$line->{chtxt_0}};
 343                 if ( !$line->{chname} ) {
 344                         # chnameが無いとき、リンクを作成しない
 345                         $line->{chname} = $line->{chtxt};
 346                         $line->{chname_link} = qq {$line->{chname}</a>};
 347                 }
 348                 else {
 349                         $line->{chname_link} = qq {<a href="rectool.pl?mode=program&amp;chtxt=$line->{chtxt}">$line->{chname}</a>};
 350                 }
 351                 $line->{title} = 'タイトルなし' if ( !$line->{title} );
 352                 $line->{tr_style} = '';
 353                 $line->{title_2} = '';
 354                 my $unix_b = str2datetime( $line->{btime} );
 355                 my $unix_e = str2datetime( $line->{etime} );
 356
 357                 my $btime = $unix_b->strftime( '%Y%m%d%H%M%S' );
 358                 my $etime = $unix_e->strftime( '%Y%m%d%H%M%S' );
 359                 if ( $extra and $line->{type} =~ /^search_|^reserve_(?!running)/ ) {
 360                         #my @ary = $dbh->selectrow_array(
 361                         #       "SELECT title, exp FROM epg_timeline
 362                         #       WHERE channel = '$line->{chname}'
 363                         #       AND start = '$btime'
 364                         #       AND stop  = '$etime' ");
 365                         #my @ary = ( $line->{epgtitle}, $line->{epgexp} );
 366                         my ( $epgtitle, $epgexp ) = ( $line->{epgtitle}, $line->{epgexp} );
 367
 368                         if ( $epgtitle ) {
 369                                 $epgtitle =~ s/無料≫//;
 370
 371                                 if ( $epgtitle ne $line->{title} ) {
 372                                         # epgtitleとtitleが一致しない
 373                                         # []に囲まれた部分を除去して比較
 374                                         my @brackets = $line->{title} =~ /(\[.+\])+/;
 375                                         my $epgtitle_nobrackets = $epgtitle;
 376                                         my $title_nobrackets = $line->{title};
 377                                         if ( @brackets && $epgtitle =~ /(\[.+\])+/ >= @brackets ) {
 378                                                 foreach ( @brackets ) {
 379                                                         $epgtitle_nobrackets =~ s/\Q$_\E//;
 380                                                 }
 381                                         }
 382                                         $title_nobrackets =~ s/(\[.+\])+//;
 383                                         if ( !scalar $epgtitle_nobrackets =~ s/\Q$title_nobrackets\E// ) {
 384                                                 # epgtitleにtitleが含まれていない
 385                                                 my $href  = qq {<a href="rectool.pl?mode=edit&amp;id=$line->{id}&amp;suggest=auto">自動検索</a>};
 386                                                 $epgtitle = qq {<span style="color: #FF4000">$epgtitle■$href■</span>};
 387                                         }
 388                                         else {
 389                                                 # epgtitleにtitleが含まれている
 390                                                 $epgtitle = $epgtitle_nobrackets;
 391                                         }
 392                                 }
 393                                 else {
 394                                         # epgtitleとtitleが一致している
 395                                         $epgtitle = '説明';
 396                                 }
 397
 398                                 $line->{title_2} = qq {<div style="float: right; cursor: help" title="$epgexp">$epgtitle</div>};
 399                         }
 400                         else {
 401                                 # epgtitleがない
 402                                 my $href    = qq {<a href="rectool.pl?mode=edit&amp;id=$line->{id}&amp;suggest=auto">自動検索</a>};
 403                                 $line->{title_2}  = qq {<span style="float: right; color: #FF0000">■$href■</span>};
 404                                 $line->{tr_style} = qq {style="background-color: #A0A0A0"};
 405                         }
 406                 }
 407
 408                 my ( $begin, $end, $diff ) = &str2readable( $unix_b, $unix_e );
 409
 410                 my $hr = '';
 411                 if (
 412                         $line->{type} eq 'reserve_running'
 413                                 &&
 414                         $unix_b->epoch <= time && time <= $unix_e->epoch
 415                 )
 416                 {
 417                         $percent = int( ( 100 * ( time - $unix_b->epoch ) ) / ( $unix_e->epoch - $unix_b->epoch ) );
 418                         $hr .= qq {<hr style="margin: 0 auto 0 0; height: 4px; width: $percent%;};
 419                         $hr .= qq { background-color: blue; border: none" title="$percent%">};
 420                 }
 421
 422                 $line->{title} = qq {<a href="rectool.pl?mode=edit&amp;id=$line->{id}">$line->{title}</a>};
 423                 #$line->{title} = qq {<div style="float: left">$line->{title}</div>} if ( $line->{title_2} );
 424                 $HTML .= qq {<tr align="center" $line->{tr_style}>\n};
 425                 $HTML .= qq {<td><input type="checkbox" name="id" value="$line->{id}"></td>\n};
 426                 $HTML .= qq {<td>$line->{id}</td>\n};
 427                 $HTML .= qq {<td>$type</td>\n};
 428                 $HTML .= qq {<td>$line->{chname_link}</td>\n};
 429                 $HTML .= qq {<td align="left" style="white-space: normal">$line->{title}$line->{title_2}</td>\n};
 430                 $HTML .= qq {<td>$begin</td>\n<td>$end</td>\n};
 431                 $HTML .= qq {<td>$hr$diff</td>\n};
 432                 $HTML .= qq {<td>$line->{opt}</td>\n<td>$line->{deltaday}</td>\n<td>$line->{deltatime}</td>\n<td>$line->{counter}</td>\n};
 433                 $HTML .= qq {</tr>\n};
 434         }
 435         $HTML .= qq {</table>\n};
 436         #$HTML .= qq {<input type="submit" name="edit" value="編集(要JS)">\n};
 437         $HTML .= qq {<input type="submit" name="delete" value="削除">\n</div>\n</form>\n};
 438         goto end;
 439 }
 440
 441 ################ mode=graph ################
 442
 443 if ( $mode eq 'graph' ) {
 444
 445         my $date = $params{ 'date' };
 446
 447         if ( $date )
 448         {
 449                 print "Content-Type: image/svg+xml\n\n";
 450
 451                 require SVG;
 452                 $date = Date::Simple->new( split /-/, $date );
 453                 $graph_bgn = $date->format('%Y-%m-%d');
 454                 $graph_end = $date->next->format('%Y-%m-%d');
 455                 $day = $date->day;
 456                 $today = $date eq Date::Simple->today() ? 1 : 0;
 457
 458                 $tuner{terrestrial} = 2; #$cfg->param( 'env.te_max' );
 459                 $tuner{satellite}   = 2; #$cfg->param( 'env.bscs_max' );
 460                 $tuner{all} = $tuner{terrestrial} + $tuner{satellite};
 461                 $hours = 24;
 462                 $width = 30 * $hours;
 463
 464                 $svg = new SVG( width => 820, height => $tuner{all} * 20 + 40 );
 465                 $svg->rectangle( 'x' => 40, 'y' => 20,
 466                         width => $width + 20, height => $tuner{all} * 20 + 10,
 467                         rx => 15, ry => 15,
 468                         style => { stroke => 'blue', fill => 'white' } );
 469                 for ( 1..$tuner{terrestrial} ) {
 470                         $svg->text( 'x' => 10, 'y' => ( $_ + 1 ) * 20 )
 471                                 ->cdata( "T$_" );
 472                 }
 473                 for ( 1..$tuner{satellite} ) {
 474                         $svg->text( 'x' => 10, 'y' => ( $_ + $tuner{terrestrial} + 1 ) * 20 )
 475                                 ->cdata( "S$_" );
 476                 }
 477                 for ( 0..$hours ) {
 478                         $svg->text( 'x' => $_ * 30 + 65, 'y' => 15,
 479                                 style => { 'text-anchor' => 'middle' } )
 480                                 ->cdata( sprintf( '%02d', $_ ) ) if ( $_ < $hours );
 481                         # $svg->line( ); # can't be used when required
 482                         $svg->tag( 'line', x1 => $_ * 30 + 50, x2 => $_ * 30 + 50, y1 => 30, y2 => $tuner{all} * 20 + 20,
 483                                 style => { stroke => 'gray' } );
 484                 }
 485                 for ( 1..$tuner{all} ) {
 486                         $svg->rectangle( 'x' => 50, 'y' => $_ * 20 + 10, width => $width, height => 10 );
 487                 }
 488                 if ( $today ) {
 489                         require Time::Simple;
 490                         my $time = Time::Simple->new();
 491                         my $x = ( $time->hours * 60 + $time->minutes ) * 0.5 + 50;
 492                         $svg->tag( 'line', x1 => $x, x2 => $x, y1 => 30, y2 => $tuner{all} * 20 + 20,
 493                                 style => { stroke => 'red', 'fill-opacity' => '1.0' } );
 494                 }
 495                 foreach my $bctype ( 'te%', '_s%' ) {
 496                         my $tuner = $bctype eq 'te%' ? $tuner{terrestrial} : $tuner{satellite};
 497                         my $ary_ref = $dbh->selectall_arrayref(
 498                                 "SELECT id, title, timeline.chtxt, btime, etime, opt FROM timeline
 499                                 INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 500                                 WHERE epg_ch.bctype LIKE '$bctype'
 501                                 AND type IN $type_user_made
 502                                 AND
 503                                 (
 504                                         '$graph_bgn 00:00' <= btime AND btime <  '$graph_end 00:00'
 505                                                 OR
 506                                         '$graph_bgn 00:00' <  etime AND etime <= '$graph_end 00:00'
 507                                 )
 508                                 ORDER BY id"
 509                                 , {Slice=>{}}
 510                         );
 511                         foreach my $line ( @{ $ary_ref } ) {
 512                                 @start = $line->{btime} =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 513                                 @stop  = $line->{etime} =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2})/;
 514                                 $start = ( ( $day == $start[2] ? 0 : 24 * 60 ) + $start[3] * 60 + $start[4] ) * 0.5;
 515                                 $stop  = ( ( $day == $stop [2] ? 0 : 24 * 60 ) + $stop [3] * 60 + $stop [4] ) * 0.5;
 516                                 $start = 0      if ( $start < 0 || $day > $start[2] ); # 月の変わり目はスルー
 517                                 $stop  = $width if ( $stop  > $width );
 518                                 $begin = $line->{btime};
 519                                 $end   = $line->{etime};
 520
 521                                 my $ary = $dbh->selectall_arrayref(
 522                                         "SELECT id, type, timeline.chtxt, title, btime, etime, opt FROM timeline
 523                                         INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
 524                                         WHERE epg_ch.bctype LIKE '$bctype'
 525                                         AND type IN $type_user_made
 526                                         AND NOT
 527                                         (
 528                                                 ( etime <= '$begin' )
 529                                                         OR
 530                                                 ( btime >= '$end'   )
 531                                         )
 532                                         ORDER BY id"
 533                                         , {Slice=>{}}
 534                                 );
 535                                 my @ary = @{$ary};
 536                                 for ( 0..$tuner - 1 ) {
 537                                         my $f = 1;
 538                                         my $i = $_;
 539                                         for ( 'chtxt', 'btime', 'etime' ) {
 540                                                 $f = 0 if ( $line->{$_} ne $ary[$i]->{$_} );
 541                                         }
 542                                         if ( $f ) {
 543                                                 $slot = $i;
 544                                         }
 545                                 }
 546                                 my ( $r, $g, $b ) = ( 0, 0, 0 );
 547                                 $r += 255 if ( $line->{opt} =~ /a/ );
 548                                 $g += 255 if ( $line->{opt} =~ /H/ );
 549                                 $b += 255 if ( $line->{opt} =~ /I/ );
 550                                 if ( $r + $g + $b == 255 * 3 ){
 551                                         $r = 0;
 552                                         $g = 255;
 553                                         $b = 255;
 554                                 }
 555                                 if ( $r + $g + $b == 0 ){
 556                                         $r = $g = $b = 128;
 557                                 }
 558                                 my %escaped = ( '&' => 'amp', '<' => 'lt', '>' => 'gt', '"' => 'quot' );
 559                                 sub html_escape{
 560                                     my $str = shift or return;
 561                                     my $result = '';
 562                                     $result .= $escaped{$_} ? '&' . $escaped{$_} . ';' : $_
 563                                         for (split //, $str);
 564                                     $result;
 565                                 }
 566                                 $svg->anchor(
 567                                         -href  => "rectool.pl?mode=edit&amp;id=$line->{id}",
 568                                         target => '_blank',
 569                                         -title => html_escape( $line->{title} ),
 570                                 )->rectangle(
 571                                         'x' => 50 + $start,
 572                                         'y' => 30 + ( $bctype eq 'te%' ? 0 : $tuner{terrestrial} * 20 ) + $slot * 20,
 573                                         width  => $stop - $start,
 574                                         height => 10,
 575                                         style  => { fill => "rgb($r,$g,$b)" } );
 576                         }
 577                 }
 578                 print $svg->xmlify;
 579                 exit;
 580         }
 581         else
 582         {
 583                 $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer - Graphical/;
 584                 $HTML .= qq {<div style="float: left">\n};
 585                 # $base64 = encode_base64( $svg->xmlify );
 586                 # $HTML .= qq {<object data="data:image/svg+xml;base64,$base64">\n</object>\n};
 587                 $HTML .= qq {予約状況一覧です。T1,T2は地上波、S1,S2はBS/CS、赤はアニメ、緑はHD、青はインターレースを示しています。<br>\n};
 588                 $HTML .= qq {SVGが利用可能なブラウザでご覧ください。<br>\n};
 589
 590                 $ary_ref = $dbh->selectcol_arrayref(
 591                         "SELECT DISTINCT DATE( btime )
 592                         FROM timeline
 593                         WHERE type in $type_user_made
 594                         ORDER BY btime"
 595                 );
 596                 foreach my $date ( @{ $ary_ref } ) {
 597                         my @date = $date =~ /(.{4})-(.{2})-(.{2})/;
 598                         my $dn = DateTime->new( year => $date[0], month => $date[1], day => $date[2], locale => 'ja_JP' )->day_name;
 599                         #utf8::encode( $dn );
 600                         $HTML .= qq {$date[1]/$date[2]($dn)の予約状況<br>\n};
 601                         # <img src="">
 602                         $HTML .= qq {<object type="image/svg+xml" data="rectool.pl?mode=graph&amp;date=$date" width="820">\n};
 603                         $HTML .= qq {SVG Image $date\n</object>\n<br>\n};
 604
 605                         $date2 = Date::Simple->new( @date )->next->format('%Y-%m-%d');
 606                         my $ary_ref = $dbh->selectall_arrayref(
 607                                 "SELECT chtxt, title, btime, etime FROM timeline
 608                                 WHERE '$date 00:00' <= btime AND etime <= '$date2 01:00'
 609                                 ORDER BY btime"
 610                         );
 611
 612                         foreach my $line ( @{ $ary_ref } ) {
 613                                 #$HTML .= qq {$line->[0] $line->[1] $line->[2] $line->[3]<br>\n};
 614                         }
 615
 616                 }
 617
 618                 goto end;
 619         }
 620 }
 621
 622 ################ mode=atom ################
 623
 624 if ( $mode eq 'atom' ) {
 625         require XML::Atom::Feed;
 626         require XML::Atom::Entry;
 627
 628         my $recording_count = $encoding_count = $jbk_count = 0;
 629         my $ary_ref = $dbh->selectall_arrayref(
 630                 "SELECT chtxt, title, btime, etime, opt
 631                 FROM timeline
 632                 WHERE type = 'reserve_running' ");
 633         foreach my $line ( @{$ary_ref} ) {
 634                 my ( $begin, $end, $diff ) = &str2readable( $line->[2], $line->[3] );
 635                 $recording_status .= qq {$line->[0] $line->[1] $begin - $end $diff $line->[4]<br />\n};
 636                 $recording_count++;
 637         }
 638         $ary_ref = $dbh->selectall_arrayref(
 639                 "SELECT chtxt, title, btime, etime, opt
 640                 FROM timeline
 641                 WHERE type = 'convert_ts_mp4_running' ");
 642         foreach my $line ( @{$ary_ref} ) {
 643                 my ( $begin, $end, $diff ) = &str2readable( $line->[2], $line->[3] );
 644                 $encoding_status .= qq {$line->[0] $line->[1] $begin - $end $diff $line->[4]<br />\n};
 645                 $encoding_count++;
 646         }
 647         $ary_ref = $dbh->selectall_arrayref(
 648                 "SELECT id, chtxt, title, btime, etime
 649                 FROM auto_timeline_keyword " );
 650         foreach my $line ( @{$ary_ref} ) {
 651                 my ( $begin, $end, $diff ) = &str2readable( $line->[3], $line->[4] );
 652                 $jbk_status .= qq {$line->[0] $line->[1] $line->[2] $begin - $end $diff<br />\n};
 653                 $jbk_count++;
 654         }
 655
 656         my $feed = XML::Atom::Feed->new( Version => 1.0 );
 657         $feed->title('Rec10 フィード');
 658
 659         my $entry = XML::Atom::Entry->new( Version => 1.0 );
 660         $entry->title("Rec10 録画状況 ($recording_count)");
 661         $entry->id('tag:recording_status');
 662         $entry->content($recording_status);
 663         $entry->add_link(str_to_link( './rectool.pl?mode=schedule' ) );
 664         $feed->add_entry($entry);
 665
 666         $entry = XML::Atom::Entry->new( Version => 1.0 );
 667         $entry->title("Rec10 縁故状況 ($encoding_count)");
 668         $entry->id('tag:encoding_status');
 669         $entry->content($encoding_status);
 670         $entry->add_link(str_to_link( './rectool.pl?mode=schedule' ) );
 671         $feed->add_entry($entry);
 672
 673         $entry = XML::Atom::Entry->new( Version => 1.0 );
 674         $entry->title("Rec10 地引状況 ($jbk_count)");
 675         $entry->id('tag:jbk_status');
 676         $entry->content($jbk_status);
 677         $entry->add_link(str_to_link( './rectool.pl?mode=jbk' ) );
 678         $feed->add_entry($entry);
 679
 680         my $xml = $feed->as_xml;
 681         print "Content-Type: application/atom+xml\n\n";
 682         print $xml;
 683         exit;
 684
 685         sub str_to_link {
 686                 my $link = XML::Atom::Link->new( Version => 1.0 );
 687                 $link->type('text/html');
 688                 $link->rel('alternate');
 689                 $link->href(shift);
 690                 return $link;
 691         }
 692 }
 693
 694 ################ mode=edit ################
 695
 696 if ( $mode eq 'edit' ) {
 697         my $id = $params{ 'id' };
 698
 699         $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Editor/;
 700         $HTML .= qq {<div style="float: left">\n};
 701
 702         $script = <<EOM;
 703                 <script type="text/javascript" src="http://www.enjoyxstudy.com/javascript/dateformat/dateformat.js">
 704                 </script>
 705                 <script type="text/javascript">
 706                 function setType(value){
 707                         var index = document.reserve.type.selectedIndex;
 708                         var value = document.reserve.type[index].value;
 709                         if ( value == 'search_everyday' ) {
 710                                 document.reserve.deltaday.value  = 7;
 711                                 document.reserve.deltatime.value = 3;
 712                         }
 713                         if ( value == 'convert_b25_ts' || value == 'convert_ts_mp4' ){
 714                                 var date       = new Date();
 715                                 var dateFormat = new DateFormat("yyyy-MM-dd HH:mm:ss");
 716                                 var minutes    = date.getMinutes();
 717                                 minutes = minutes - minutes % 5 + 10;
 718                                 date.setMinutes(minutes, 0, 0);
 719                                 document.reserve.begin.value = dateFormat.format(date);
 720                                 date.setSeconds( date.getSeconds() + 3600 );
 721                                 document.reserve.end.value   = dateFormat.format(date);
 722                         }
 723                 }
 724                 function setSuggest(start, stop){
 725                         document.reserve.begin.value = start;
 726                         document.reserve.end.value   = stop;
 727                 }
 728                 function shiftEndTime(value){
 729                         var dateFormat = new DateFormat("yyyy-MM-dd HH:mm:ss");
 730                         var date = dateFormat.parse(document.reserve.end.value || document.reserve.begin.value);
 731                         date.setSeconds( date.getSeconds() + value );
 732                         document.reserve.end.value = dateFormat.format(date);
 733                 }
 734                 </script>
 735 EOM
 736         $script =~ s/^\t{2}//gm;
 737         $HTML =~ s/%SCRIPT%/$script/;
 738
 739         $HTML .= "スケジュール編集画面です。<br>\n";
 740         $HTML .= "実装がとても適当なので、利用には細心の注意を払ってください。<br>\n<br>\n";
 741         if ( $id ) {
 742                 # 予約の編集
 743                 &parse_program();
 744                 $button_bgn = $button_end = '';
 745         }
 746         else {
 747                 # 新規予約
 748                 $type = 'reserve_flexible';
 749                 $counter = -1;
 750                 $datetime_now = DateTime->now( time_zone => $tz )->set_second( 0 )->add( minutes => 1)->strftime( '%Y-%m-%d %H:%M:%S' );
 751                 $button_bgn = qq{<button type="button" onClick="document.reserve.begin.value='$datetime_now'">現在</button>\n<br>\n};
 752                 $button_end =
 753                          qq{<button type="button" onClick="document.reserve.end.value=document.reserve.begin.value">一致</button>}
 754                         .qq{<button type="button" onClick="shiftEndTime(300);">+5m</button>}
 755                         .qq{<button type="button" onClick="shiftEndTime(1800);">+30m</button>};
 756         }
 757
 758         if ( $params{ 'suggest' } eq 'auto' ) {
 759                 my @btime = $begin =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 760                 my @etime = $end   =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
 761                 my $btime = DateTime->new(
 762                         year => $btime[0], month  => $btime[1], day    => $btime[2],
 763                         hour => $btime[3], minute => $btime[4], second => $btime[5],
 764                 );
 765                 my $etime = DateTime->new(
 766                         year => $etime[0], month  => $etime[1], day    => $etime[2],
 767                         hour => $etime[3], minute => $etime[4], second => $etime[5],
 768                 );
 769                 my %hash = &sqlgetsuggested( $btime, $etime );
 770
 771                 $HTML .= qq {可能性のある番組<br>\n};
 772                 $HTML .= qq {<table summary="suggesttable" border=1 cellspacing=0>\n<tr>\n};
 773                 $HTML .= qq {<th>優先度</th>\n};
 774                 $HTML .= qq {<th>タイトル</th>\n};
 775                 $HTML .= qq {<th>開始時刻</th>\n};
 776                 $HTML .= qq {<th>終了時刻</th>\n};
 777                 $HTML .= qq {<th>説明</th>\n};
 778                 $HTML .= qq {<th>適用</th>\n};
 779                 $HTML .= qq {</tr>\n};
 780
 781                 foreach my $key (sort keys %hash){
 782                         my $val = $hash{$key};
 783                         foreach my $val ( @{$val} ) {
 784                                 my $style = qq {style="white-space: nowrap"};
 785                                 $val->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 786                                 $val->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 787                                 $HTML .= qq {<tr>\n<td>$key</td>\n<td>$val->[2]</td>\n};
 788                                 $HTML .= qq {<td $style>$val->[0]</td>\n<td $style>$val->[1]</td>\n<td>$val->[3]</td>\n};
 789                                 $HTML .= qq {<td><button onClick="setSuggest('$val->[0]','$val->[1]');">適用</button></td>\n</tr>\n};
 790                         }
 791                 }
 792                 $HTML .= qq {</table>\n<br>\n};
 793         }
 794
 795         my $len = length $id;
 796         $HTML .= qq {<form method="get" action="rectool.pl" name="reserve">\n};
 797         $HTML .= qq {<input type="hidden" name="mode" value="change">\n};
 798         $HTML .= qq {<input type="hidden" name="mode_sub" value="update">\n};
 799         $HTML .= qq {<input type="hidden" name="id" value="$id">\n};
 800         $HTML .= qq {ID\n<input type="text" name="id" value="$id" size=$len disabled>\n};
 801         $HTML .= qq {タイプ\n<select name="type" onChange="setType();">\n};
 802         foreach my $key ( keys %type ) {
 803                 next if ( $key !~ /^search|^reserve_flexible$|^reserve_fixed$|^convert_b25_ts$|^convert_ts_mp4$|^$type$/ );
 804                 $value = $type{$key};
 805                 if ( $key eq $type ) {
 806                         $HTML .= qq {<option value="$key" selected>$value</option>\n};
 807                 }
 808                 else {
 809                         $HTML .= qq {<option value="$key">$value</option>\n};
 810                 }
 811         }
 812         $HTML .= qq {</select>\n};
 813
 814         $HTML .= qq {チャンネル\n<select name="chtxt">\n};
 815         # 移動縁故など、チャンネルリスト内にchtxtが存在しない場合に備えて
 816         $chtxt_0_chname{$chtxt} = $chname || $chtxt if ( !$chtxt_0_chname{$chtxt} );
 817         foreach my $key ( sort keys %chtxt_0_chname ) {
 818                 if ( $key eq $chtxt || $key eq $chtxt_0 ) {
 819                         $HTML .= qq {<option value="$key" selected>$chtxt_0_chname{$key}</option>\n};
 820                 }
 821                 else {
 822                         $HTML .= qq {<option value="$key">$chtxt_0_chname{$key}</option>\n};
 823                 }
 824         }
 825         $HTML .= qq {</select><br>\n};
 826         $HTML .= qq {タイトル\n<input type="text" name="title" value="$title" size=64><br>\n};
 827         $HTML .= qq {開始時刻\n<input type="text" name="begin" value="$begin" maxlength=19 size=24>\n};
 828         $HTML .= $button_bgn;
 829         $HTML .= qq {終了時刻\n<input type="text" name="end" value="$end" maxlength=19 size=24>\n};
 830         $HTML .= $button_end . "<br>\n";
 831         $HTML .= qq {隔日周期\n<input type="text" name="deltaday" value="$deltaday" maxlength=2  size=2 >\n};
 832         $HTML .= qq {時刻誤差\n<input type="text" name="deltatime" value="$deltatime" maxlength=2  size=2 >\n};
 833         $HTML .= qq {オプション\n<input type="text" name="opt" value="$opt">\n};
 834         $HTML .= qq {回数\n<input type="text" name="counter" value="$counter" size=2 >\n};
 835         $HTML .= qq {<input type="submit" name="update" value="更新">\n</form>\n};
 836 }
 837
 838 ################ mode=change ################
 839
 840 if ( $mode eq 'change' ) {
 841         @id     = $q->param( 'id' );
 842
 843         $HTML =~ s/%HTML_TITLE_OPT%/ - Change/;
 844         $HTML .= qq {<div style="float: left">\n};
 845
 846         if ( $params{ 'delete' } )
 847         {
 848                 if ( @id ) {
 849                         foreach my $id ( @id ) {
 850                                 $dbh->do( "DELETE FROM timeline WHERE id = '$id'" );
 851                         }
 852                         $HTML .= "削除しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 853                         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 854                         goto end;
 855                 }
 856         }
 857         if ( $params{ 'update' } )
 858         {
 859                 $type      = $params{ 'type' };
 860                 $chtxt     = $params{ 'chtxt' };
 861                 $title     = $params{ 'title' };
 862                 $begin     = $params{ 'begin' };
 863                 $end       = $params{ 'end' };
 864                 $deltaday  = $params{ 'deltaday' };
 865                 $deltatime = $params{ 'deltatime' };
 866                 $opt       = $params{ 'opt' };
 867                 $counter   = $params{ 'counter' };
 868                 $id        = $id[0];
 869                 if ( $id ) {
 870                         $dbh->do(
 871                                 "UPDATE timeline SET type = '$type', chtxt = '$chtxt', title = '$title',
 872                                 btime = '$begin', etime = '$end',
 873                                 deltaday = '$deltaday', deltatime = '$deltatime', opt = '$opt', counter = '$counter'
 874                                 WHERE id = '$id'"
 875                         );
 876                 }
 877                 else {
 878                         $dbh->do(
 879                                 "INSERT INTO timeline ( type, chtxt, title, btime, etime, deltaday, deltatime, opt, counter )
 880                                 VALUES ( '$type', '$chtxt', '$title', '$begin', '$end', '$deltaday', '$deltatime', '$opt', '$counter' )"
 881                         );
 882                 }
 883                 $HTML .= "更新しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
 884                 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
 885                 goto end;
 886         }
 887         if ( $mode_sub eq 'proc' ) {
 888                 my $type  = $params{ 'type' };
 889                 my $chtxt = $params{ 'chtxt' } || 'nhk-k';
 890                 my $title = $params{ 'title' };
 891                 my @opt   = $q->param( 'opt' );
 892                 my $opt   = join '', @opt;
 893
 894                 my $datetime_now = DateTime->now( time_zone => $tz )->set_second( 0 )->add( minutes => 10);
 895                 my $sql_type = $type_suggest{$type};
 896                 my $begin = $datetime_now->strftime( '%Y-%m-%d %H:%M:%S' );
 897                 $datetime_now = $datetime_now->add( minutes => 60 );
 898                 my $end = $datetime_now->strftime( '%Y-%m-%d %H:%M:%S' );
 899
 900                 $dbh->do(
 901                         "INSERT INTO timeline ( type, chtxt, title, btime, etime, opt )
 902                         VALUES ( '$sql_type', '$chtxt', '$title', '$begin', '$end', '$opt' )"
 903                 );
 904
 905                 goto end;
 906         }
 907         if ( $mode_sub eq 'move' ) {
 908                 my $mode_sub2  = $params{ 'mode_sub2' };
 909                 my $title      = $params{ 'title' };
 910                 my $response;
 911
 912                 $ENV{'LANG'} = 'ja_JP.UTF-8';
 913                 if ( $mode_sub2 eq 'predict' ) {
 914                         $HTML .= "移動後のシミュレーション結果です。\n<br>";
 915                         eval '$response = `python26 ' . $cfg->param( 'path.rec10' ) . "/classify.py -s '$title'`";
 916                 }
 917                 elsif ( $mode_sub2 eq 'exec' ) {
 918                         eval '$response = `python26 ' . $cfg->param( 'path.rec10' ) . "/classify.py -e '$title'`";
 919                 }
 920                 utf8::decode( $response );
 921                 $HTML .= $response;
 922
 923                 goto end;
 924         }
 925         if ( $mode_sub eq 'setting' ) {
 926                 my $jbk     = $params{ 'jbk' }     || '0';
 927                 my $bayes   = $params{ 'bayes' }   || '0';
 928                 my $del_tmp = $params{ 'del_tmp' } || '0';
 929                 my $opt     = $params{ 'opt' }     || '';
 930                 my $user    = $params{ 'user' }    || '';
 931                 my $pass    = $params{ 'pass' }    || '';
 932
 933                 $dbh->do(
 934                         "UPDATE in_settings SET auto_jbk = '$jbk', auto_bayes = '$bayes',
 935                         auto_del_tmp = '$del_tmp', auto_opt = '$opt'"
 936                 );
 937
 938                 goto end;
 939         }
 940         if ( $mode_sub eq 'fixstatus' ) {
 941                 my $key = $params{ 'terec'  } ? 'terec'  : $params{ 'bscsrec' } ? 'bscsrec' :
 942                           $params{ 'b252ts' } ? 'b252ts' : $params{ 'ts2avi'  } ? 'ts2avi'  : '';
 943
 944                 $dbh->do(
 945                         "UPDATE in_status SET $key = 0"
 946                 );
 947
 948                 goto end;
 949         }
 950
 951 }
 952
 953 ################ mode=confirm ################
 954
 955 if ( $mode eq 'confirm' ) {
 956         if ( $mode_sub eq 'reserve' ) {
 957                 $HTML =~ s/%HTML_TITLE_OPT%/ - Reserver/;
 958                 $HTML .= qq {<div style="float: left">\n};
 959                 &parse_program();
 960
 961                 my $duration = ( str2datetime( $end ) - str2datetime( $begin ) )->delta_minutes;
 962                 $HTML .= "番組名：$title<br>\nチャンネル：$chname<br>\n放送継続時間：$duration 分<br>\n番組内容：$desc<br>\n";
 963                 if ( $longdesc ) {
 964                         $longdesc =~ s/\\n/<br>\n/gs;
 965                         $HTML .= "番組内容(長)：$longdesc<br>\n";
 966                 }
 967                 my $error = &check_error();
 968                 if ( $error )
 969                 {
 970                         # エラー
 971
 972                         $ary_ref = $dbh->selectall_arrayref(
 973                                 "SELECT start, stop FROM epg_timeline WHERE channel = '$chtxt' AND title = '$title' "
 974                         );
 975                         if ( $error != 1 ) {
 976                                 $HTML .= "同一の番組の他の放送予定です。<br>\n";
 977                                 foreach my $line ( @{$ary_ref} ) {
 978                                         $begin = $line->[0];
 979                                         $end   = $line->[1];
 980                                         $begin =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 981                                         $end   =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
 982                                         $overlap = &get_overlap() >= 2 ? '不可能' :
 983                                                 qq {<a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chtxt=$chtxt&amp;start=$line->[0]&amp;stop=$line->[1]">可能</a>};
 984                                         $HTML .= "開始：$begin\n終了：$end\n録画は$overlap<br>\n";
 985                                 }
 986                         }
 987                 }
 988                 else {
 989                         $HTML .= "録画予約の詳細設定を行ってください。<br>\n";
 990                         $HTML .= qq {<form method="get" action="rectool.pl">\n};
 991                         $HTML .= qq {<input type="hidden" name="mode"  value="reserve">\n};
 992                         $HTML .= qq {<input type="hidden" name="chtxt" value="$chtxt">\n};
 993                         $HTML .= qq {<input type="hidden" name="start" value="$start">\n};
 994                         $HTML .= qq {<input type="hidden" name="stop"  value="$stop">\n};
 995                         $HTML .= qq {<input type="hidden" name="title" value="$title">\n} if ( $params{ 'title' } );
 996                         &draw_form_opt( 'reserve' );
 997                         $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
 998                 }
 999                 goto end;
1000         }
1001         # End of $mode_sub eq 'reserve';
1002
1003         if ( $mode_sub eq 'proc' ) {
1004                 my    $type  = $params{ 'type' };
1005                 local $chtxt = $params{ 'chtxt' };
1006                 my    $title = $params{ 'title' };
1007                 local $opt   = $params{ 'opt' };
1008                 utf8::decode( $title );
1009
1010                 $HTML .= "詳細設定を行ってください。<br>\n";
1011                 $HTML .= "タイトル：$title\n<br>\n";
1012
1013                 $HTML .= qq {<form method="get" action="rectool.pl">\n};
1014                 $HTML .= qq {<input type="hidden" name="mode"     value="change">\n};
1015                 $HTML .= qq {<input type="hidden" name="mode_sub" value="proc">\n};
1016                 $HTML .= qq {<input type="hidden" name="type"     value="$type">\n};
1017                 $HTML .= qq {<input type="hidden" name="title"    value="$title">\n};
1018                 &draw_form_channel( 'nonone' );
1019                 &draw_form_opt();
1020                 $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
1021                 goto end;
1022         }
1023 }
1024
1025 ################ mode=reserve ################
1026
1027 if ( $mode eq 'reserve' ) {
1028         $HTML .= qq {<div style="float: left">\n};
1029         &parse_program();
1030         $title = $params{ 'title' } if ( !$title );
1031         @opt = $q->param( 'opt' );
1032         $opt = join '', @opt;
1033         my ( $deltaday, $deltatime );
1034
1035         if ( $params{'every'} eq '1' ) {
1036                 $type = 'search_everyday';
1037                 ( $changed_t ) = $title =~ /(.*)#/;
1038                 $title = $changed_t if ( $changed_t );
1039                 ( $changed_t ) = $title =~ /(.*)第/;
1040                 $title = $changed_t if ( $changed_t );
1041                 ( $changed_t ) = $title =~ /(.*)▽/;
1042                 $title = $changed_t if ( $changed_t );
1043                 $title =~ s/「.*」//;
1044                 $title =~ s/＜.*＞//;
1045                 $title =~ s/（.*）//;
1046                 $title =~ s/\[新\]//;
1047                 $title =~ s/無料≫//;
1048                 $title =~ s/\s*$//;
1049                 $deltaday  = 7;
1050                 $deltatime = 3;
1051         }
1052         else {
1053                 $type = 'reserve_flexible';
1054         }
1055         $chtxt = $chtxt_0 if ( $chtxt_0 );
1056         if ( !&check_error ) {
1057                 $dbh->do(
1058                         "INSERT INTO timeline ( type, chtxt, title, btime, etime, opt, deltaday, deltatime )
1059                         VALUES ( '$type', '$chtxt', '$title', '$begin', '$end', '$opt', '$deltaday', '$deltatime' )"
1060                 );
1061         }
1062         $HTML .= "録画予約を実行しました。<br>\n5秒後にトップへ移動します。<br>\n";
1063         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl">|;
1064         goto end;
1065 }
1066
1067 ################ mode=program ################
1068
1069 if ( $mode eq 'program' ) {
1070         &draw_form();
1071
1072         $HTML =~ s/%HTML_TITLE_OPT%/ - Program Viewer/;
1073         $unix = DateTime->now( time_zone => $tz )->strftime( '%Y%m%d%H%M%S' );
1074         $sql =
1075                 "SELECT channel, epg_ch.chname, start, stop, title, category
1076                 FROM epg_timeline
1077                 INNER JOIN epg_ch ON epg_timeline.channel = epg_ch.chtxt
1078                 WHERE $unix <= stop %CH% %DATE% %CATEGORY% %KEY% ORDER BY start";
1079
1080         if ( $chtxt ) {
1081                 my $ch;
1082                 if ( $chtxt =~ /^\d+(_0)?$/ ) {
1083                         # teはxx_yyy形式であるため
1084                         $chtxt =~ s/_0//;
1085                         $ch = "AND channel LIKE '$chtxt\_%'";
1086                 }
1087                 else {
1088                         $ch = "AND channel = '$chtxt'";
1089                 }
1090                 $sql =~ s/%CH%/$ch/;
1091         }
1092         if ( $date_sel ) {
1093                 $date_1 = $date_sel . '000000';
1094                 $date_2 = Date::Simple->new( $date_sel =~ /(.{4})(.{2})(.{2})/ )->next->format('%Y%m%d') . '000000';
1095                 my $date = "AND '$date_1' <= stop AND start <= '$date_2'";
1096                 $sql =~ s/%DATE%/$date/;
1097         }
1098         if ( $category_sel ) {
1099                 # 一時的
1100                 #       $category_tmp = $category{$category_sel} . $category_sel;
1101                 my $category = "AND category = '$category{$category_sel}'";
1102                 $sql =~ s/%CATEGORY%/$category/;
1103         }
1104         if ( $key ) {
1105                 my $key = "AND TITLE LIKE '%$key%'";
1106                 $sql =~ s/%KEY%/$key/;
1107         }
1108         $sql =~ s/%CH%//;
1109         $sql =~ s/%DATE%//;
1110         $sql =~ s/%KEY%//;
1111         $sql =~ s/%CATEGORY%//;
1112
1113         $ary_ref = $dbh->selectall_arrayref( $sql );
1114         foreach my $prg ( @{ $ary_ref } ) {
1115                 my @date = $prg->[2] =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
1116
1117                 $date = $date[2];
1118                 if ( $date != $prev ) {
1119                         my $date = DateTime->new(
1120                                 year => $date[0], month  => $date[1], day    => $date[2],
1121                                 locale => 'ja_JP'
1122                         );
1123
1124                         my $dn = $date->day_name;
1125                         #utf8::encode( $dn );
1126                         $HTML .= qq {--------$date[1]/$date[2]($dn)--------<br>\n};
1127                 }
1128                 $HTML .= qq {$date[1]/$date[2] $date[3]:$date[4] };
1129                 $HTML .= qq {$prg->[1] } if ( !$chtxt );
1130                 $HTML .= qq {<a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chtxt=$prg->[0]&amp;start=$prg->[2]&amp;stop=$prg->[3]">$prg->[4]</a><br>\n};
1131                 $prev = $date;
1132         }
1133 }
1134
1135 ################ mode=list ################
1136
1137 if ( $mode eq 'list' ) {
1138         $HTML =~ s/%HTML_TITLE_OPT%/ - List/;
1139         $HTML .= qq {<div>\n};
1140
1141         my $recording   = $cfg->param( 'path.recpath' );
1142         my $ts_movepath = $cfg->param( 'path.ts_movepath' );
1143         my $recorded    = $cfg->param( 'path.recorded' );
1144
1145         if ( $mode_sub eq 'log' ) {
1146                 my $title = $params{ 'title' };
1147                 my $log = slurp( "$recording/$title.log" ) if ( -e "$recording/$title.log" );
1148                 utf8::decode( $log );
1149                 $HTML .= '<pre>'.$log."</pre>\n";
1150                 goto end;
1151         }
1152         if ( !$mode_sub ) {
1153                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;mode_sub=new">録画中のみ</a>\n};
1154                 $HTML .= qq {<a href="rectool.pl?mode=list&amp;mode_sub=old">録画後のみ</a>\n<br>\n};
1155         }
1156         if ( !$mode_sub || $mode_sub eq 'new' ) {
1157                 $HTML .= "録画中のファイル一覧<br>\n";
1158                 &list( $recording );
1159         }
1160         if ( !$mode_sub ) {
1161                 $HTML .= "<br>\n";
1162         }
1163         if ( !$mode_sub || $mode_sub eq 'old' ) {
1164                 $HTML .= "録画後のファイル一覧<br>\n";
1165                 &simple_list( $ts_movepath );
1166                 &simple_list( $recorded );
1167         }
1168
1169         sub list {
1170                 local $path = shift;
1171                 local %list = ();
1172                 my @exp = ( 'log', 'log.zip', 'ts.b25', 'ts.tsmix', 'ts', 'ts.log',
1173                         'aac', 'srt', 'm2v', 'wav', '264', 'mp4', 'mkv' );
1174                 for ( 0..$#exp ) {
1175                         $exp{$exp[$_]} = $_;
1176                 }
1177                 my $exp_count = scalar keys %exp;
1178
1179                 &get_file_list_wrapper( $path, \&wanted );
1180
1181                 my $help;
1182                 foreach my $name ( sort { $exp{$a} <=> $exp{$b} } keys %exp ) {
1183                         $help .= $exp{$name} + 1 . " = $name / ";
1184                 }
1185                 $HTML .= $help;
1186                 $help  = qq {<tr style="background-color: #87CEEB"><td>$help\n</td>\n};
1187                 $help .= qq {<td>$_</td>\n} for ( 1..$exp_count );
1188                 $help .= qq {<td colspan="2">自動移動</td>\n</tr>\n};
1189                 $help .= qq {<tr>\n</tr>\n};
1190
1191                 $HTML .= qq {<br>\n○ = 完了 / ● = 書き込み中 / ◆ = ファイルサイズ異常<br>\n};
1192                 $HTML .= qq {<table summary="listtable" border=1 cellspacing=0>\n<tr>\n};
1193                 $HTML .= qq {<th>タイトル</th>\n};
1194                 $HTML .= qq {<th>$_</th>\n} for ( 1..$exp_count );
1195                 $HTML .= qq {<th colspan="2">自動移動</th>\n};
1196                 $HTML .= qq {</tr>\n};
1197
1198                 my $count = 0;
1199
1200                 foreach my $title ( sort keys %list ) {
1201                         my $value = $list{$title};
1202                         my @flag = ( 0 ) x ( $exp_count );
1203                         $HTML .= qq {<tr>\n<td width="600" style="width: 600px; white-space: normal">$title</td>\n};
1204                         foreach my $exp ( keys %{$value} ) {
1205                                 if ( $exp eq 'log' ) {
1206                                         my $title = $q->escape( $title );
1207                                         my $check = qq {<td><a href="rectool.pl?mode=list&amp;mode_sub=log&amp;title=$title">○</a></td>\n};
1208
1209                                         $value->{$exp}->{check} = $check;
1210                                 }
1211                                 elsif ( $exp eq 'mkv' ) {
1212                                         my $title = $q->escape( $title );
1213
1214                                         my $check = qq {<td><a title="$value->{$exp}->{size}" href="rectool.pl?mode=thumb&amp;title=$title">■</a></td>\n};
1215                                         $value->{$exp}->{check} = $check;
1216                                 }
1217                                 $flag[$exp{$exp}] = $value->{$exp};
1218                         }
1219                         if ( !$flag[$exp{'mkv'}] ) {
1220                                 $flag[@flag]->{check} = qq {<td colspan="2"><br></td>\n};
1221                         }
1222                         else {
1223                                 my $title = $q->escape( $title );
1224
1225                                 $flag[@flag]->{check} =
1226                                         qq {<td><a href="rectool.pl?mode=change&amp;mode_sub=move&amp;mode_sub2=predict&amp;title=$title">予測</a></td>\n}.
1227                                         qq {<td><a href="rectool.pl?mode=change&amp;mode_sub=move&amp;mode_sub2=exec&amp;title=$title">実行</a></td>\n};
1228                         }
1229                         foreach ( @flag ) {
1230                                 my $size = $_->{size};
1231                                 my $last = $_->{last} || ( $_->{size} eq '0 B' ? '◆' : '○' );
1232                                 my $check =  $size ? qq {<span title="$size">$last</span>} : '<br>';
1233                                 $HTML .= $_->{check} ? $_->{check} : qq {<td>$check</td>\n};
1234                         }
1235                         $HTML .= qq {</tr>\n};
1236                         $HTML .= $help unless ( ++$count % 20 );
1237                 }
1238                 $HTML .= qq {</table>\n};
1239
1240                 sub wanted {
1241                         my $rel = shift;
1242                         my $abs = shift;
1243
1244                         return if ( $rel =~ /Thumbs\.db/ );
1245                         return if ( $rel =~ /\.idx/ );
1246
1247                         $rel =~ s/\.temp$//;
1248                         my $regexp = join '|', keys %exp;
1249                         my ( $title, $exp ) = $rel =~ /(.*?)\.($regexp)$/;
1250                         my ( $size, $last ) = &get_size( $abs );
1251                         $rel =~ s/\.temp$//;
1252                         if ( !$title ) {
1253                                 $title = '_error_exp_'.$rel;
1254                                 $exp   = 'log';
1255                         }
1256                         if ( $title !~ /[^0-9A-F]+/ ) {
1257                                 my $tmp = pack( 'H*', $title );
1258                                 if ( !$tmp ) {
1259                                         $title = '_error_b16_'.$rel;
1260                                         $exp   = 'log';
1261                                 }
1262                                 else {
1263                                         $title = 'Base16_'.$tmp;
1264                                 }
1265                         }
1266                         $list{$title}->{$exp} = { 'last' => $last, 'size' => $size };
1267                 }
1268         }
1269
1270         sub simple_list {
1271                 require Encode;
1272
1273                 local $path = shift;
1274                 local @list = ();
1275
1276                 &get_file_list_wrapper( $path, \&simple_wanted );
1277
1278 #               @list = sort @list;
1279                 # natural sortを行う
1280                         #@list = map( Encode::decode_utf8( $_ ), @list );
1281                         @list = nsort @list;
1282                         #@list = map( Encode::encode_utf8( $_ ), @list );
1283
1284                 foreach ( @list ) {
1285                         $HTML .= "$_<br>\n";
1286                 }
1287
1288                 sub simple_wanted {
1289                         my $rel = shift;
1290                         my $abs = shift;
1291
1292                         my ( $size ) = &get_size( $abs );
1293                         push @list, $rel ."\t\t". $size;
1294                 }
1295         }
1296
1297         sub get_size {
1298                 my $file = shift;
1299                 my ( $size, $last ) = (stat( $file ))[7,9];
1300                 my @unim = ("B","KiB","MiB","GiB","TiB","PiB");
1301                 my $count = 0;
1302
1303                 while($size >= 1024 ){
1304                         $count++;
1305                         $size = $size / 1024;
1306                 }
1307                 $size *= 100;
1308                 $size  = int( $size );
1309                 $size /= 100;
1310                 if ( time - $last < 10 ) {
1311                         $last = '●';
1312                 }
1313                 else {
1314                         $last = '';
1315                 }
1316                 return ( "$size $unim[$count]", $last );
1317         }
1318 }
1319
1320 ################ mode=thumb ################
1321
1322 if ( $mode eq 'thumb' ) {
1323         my $title = $params{ 'title' };
1324         my $pos  = $params{ 'pos' };
1325         my $recording = $cfg->param( 'path.recpath' );
1326
1327         print "Content-Type: image/jpeg\n\n";
1328         exec "ffmpeg -ss 300 -i '$recording/$title.mkv' -f image2 -pix_fmt jpg -vframes 1 -s 320x240 -";
1329         exit;
1330 }
1331
1332 ################ mode=check ################
1333
1334 if ( $mode eq 'check' ) {
1335 }
1336
1337 ################ mode=bravia ################
1338
1339 if ( $mode eq 'bravia' ) {
1340         $HTML =~ s/%HTML_TITLE_OPT%/ - Bravia/;
1341         $HTML .= qq {<div>\n};
1342         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1343         $HTML .= qq {<div>\n};
1344         $HTML .= qq {<table summary="bayestable" border=1 cellspacing=0>\n<tr>\n};
1345         $HTML .= qq {<th>ID</th>\n};
1346         $HTML .= qq {<th>チャンネル</th>\n};
1347         $HTML .= qq {<th>タイトル</th>\n};
1348         $HTML .= qq {<th><a href="rectool.pl?mode=bravia">開始時刻</a></th>\n};
1349         $HTML .= qq {<th>終了時刻</th>\n};
1350         $HTML .= qq {<th>録画時間</th>\n};
1351         $HTML .= qq {<th><a href="rectool.pl?mode=bravia&amp;order=point">ポイント</a></th>\n};
1352         $HTML .= qq {<th>予約</th>\n};
1353         $HTML .= qq {</tr>\n};
1354         my $order = $params{ 'order' };
1355         if ( $order ne 'point' ) {
1356                 $order = 'btime';
1357         }
1358         else {
1359                 $order = 'point DESC';
1360         }
1361         my $ary_ref = $dbh->selectall_arrayref(
1362                 "SELECT id, chtxt, title, btime, etime, point
1363                 FROM auto_timeline_bayes
1364                 ORDER BY $order" );
1365
1366         foreach my $line ( @{ $ary_ref } ) {
1367                 my ( $begin, $end, $diff ) = &str2readable( $line->[3], $line->[4] );
1368
1369                 $line->[1] = $chtxt_chname{$line->[1]} || $line->[1];
1370                 $HTML .= qq {<tr align="center">\n};
1371                 $HTML .= qq {<td>$line->[0]</td>\n};
1372                 $HTML .= qq {<td>$line->[1]</td>\n};
1373                 $HTML .= qq {<td>$line->[2]</td>\n};
1374                 $HTML .= qq {<td>$begin</td>\n<td>$end</td>\n<td>$diff</td>\n};
1375                 $HTML .= qq {<td>$line->[5]</td>\n};
1376                 $HTML .= qq {<td><a href="rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;bayesid=$line->[0]">予約</a></td>\n};
1377                 $HTML .= qq {</tr>\n};
1378         }
1379         $HTML .= qq {</table>\n};
1380         $HTML .= qq {</div>\n};
1381         $HTML .= qq {</form>\n};
1382
1383 }
1384
1385 ################ mode=proc ################
1386
1387 if ( $mode eq 'proc' ) {
1388         $HTML =~ s/%HTML_TITLE_OPT%/ - Proposal/;
1389         $HTML .= qq {<div>\n};
1390         $HTML .= qq {<table summary="proctable" border=1 cellspacing=0>\n<tr>\n};
1391         $HTML .= qq {<th>タイプ</th>\n};
1392         $HTML .= qq {<th>タイトル</th>\n};
1393         $HTML .= qq {<th>予約</th>\n};
1394         $HTML .= qq {</tr>\n};
1395
1396         my $ary_ref = $dbh->selectall_arrayref(
1397                 "SELECT type, chtxt, title
1398                 FROM auto_proc
1399                 ORDER BY title " );
1400
1401         foreach my $line ( @{ $ary_ref } ) {
1402                 my $url;
1403                 $line->[3] = $q->escape( $line->[2] );
1404                 my $opt = $dbh->selectrow_array(
1405                         "SELECT opt FROM in_timeline_log
1406                         WHERE title = '$line->[2]' "
1407                 );
1408
1409                 if ( $line->[0] eq 'auto_suggest_dec' ) {
1410                         unless ( $dbh->selectrow_array(
1411                                 "SELECT 1 FROM timeline
1412                                 WHERE ( type = 'convert_b25_ts' OR type = 'convert_b25_ts_running' )
1413                                 AND title = '$line->[2]' "
1414                         ) ) {
1415                                 $url = qq {rectool.pl?mode=confirm&amp;mode_sub=proc&amp;type=$line->[0]&amp;chtxt=$line->[1]&amp;title=$line->[3]&amp;opt=$opt};
1416                         }
1417                 }
1418                 elsif ( $line->[0] eq 'auto_suggest_enc' ) {
1419                         unless ( $dbh->selectrow_array(
1420                                 "SELECT 1 FROM timeline
1421                                 WHERE ( type = 'convert_ts_mp4' OR type = 'convert_ts_mp4_running' )
1422                                 AND title = '$line->[2]' "
1423                         ) ) {
1424                                 $url = qq {rectool.pl?mode=confirm&amp;mode_sub=proc&amp;type=$line->[0]&amp;chtxt=$line->[1]&amp;title=$line->[3]&amp;opt=$opt};
1425                         }
1426                 }
1427                 else {
1428                         unless ( $dbh->selectrow_array(
1429                                 "SELECT 1 FROM timeline
1430                                 WHERE ( type LIKE 'convert_avi%' OR type = 'convert_mkv' )
1431                                 AND title = '$line->[2]' "
1432                         ) ) {
1433                                 $url = qq {rectool.pl?mode=confirm&amp;mode_sub=proc&amp;type=$line->[0]&amp;chtxt=$line->[1]&amp;title=$line->[3]};
1434                         }
1435                 }
1436                 if ( $url ) {
1437                         $href = qq {<a href="$url">予約</a>};
1438                 }
1439                 else {
1440                         $href = q {予約済};
1441                 }
1442
1443                 my $color = $color{$type_suggest{$line->[0]}} ? $color{$type_suggest{$line->[0]}} : '';
1444                 $line->[0] = $type{$line->[0]} ? $type{$line->[0]} : $line->[0];
1445                 $line->[0] = qq {<span style="color: $color">$line->[0]</span>} if ( $color );
1446                 $HTML .= qq {<tr align="center">\n};
1447                 $HTML .= qq {<td>$line->[0]</td>\n};
1448                 $HTML .= qq {<td align="left">$line->[2]</td>\n};
1449                 $HTML .= qq {<td>$href</td>\n};
1450                 $HTML .= qq {</tr>\n};
1451         }
1452
1453         $HTML .= qq {</table>\n};
1454 }
1455
1456 ################ mode=jbk ################
1457
1458 if ( $mode eq 'jbk' ) {
1459         $HTML =~ s/%HTML_TITLE_OPT%/ - JBK/;
1460         $HTML .= qq {<div>\n};
1461
1462         if ( $mode_sub eq 'add' ) {
1463                 my $keyword = $params{ 'keyword' };
1464                 utf8::decode( $keyword );
1465                 $HTML .= "キーワード「$keyword」を追加しました。<br>\n";
1466                 $dbh->do(
1467                         "INSERT INTO in_auto_jbk_key ( keyword )
1468                         VALUES ( '$keyword' )"
1469                 );
1470         }
1471         elsif ( $mode_sub eq 'del' ) {
1472                 my $id = $params{ 'id' };
1473                 my $keyword = $dbh->selectrow_array(
1474                         "SELECT keyword FROM in_auto_jbk_key
1475                         WHERE id = '$id' " );
1476                 $HTML .= "キーワード「$keyword」を削除しました。<br>\n";
1477                 $dbh->do(
1478                         "DELETE FROM in_auto_jbk_key WHERE id = '$id'"
1479                 );
1480         }
1481         elsif ( $mode_sub eq 'on' ) {
1482                 my $id = $params{ 'id' };
1483                 $HTML .= "キーワード「$keyword」を自動録画対象にしました。<br>\n";
1484                 $dbh->do(
1485                         "UPDATE in_auto_jbk_key SET auto = 1 WHERE id = '$id'"
1486                 );
1487         }
1488         elsif ( $mode_sub eq 'off' ) {
1489                 my $id = $params{ 'id' };
1490                 $HTML .= "キーワード「$keyword」を自動録画対象から外しました。<br>\n";
1491                 $dbh->do(
1492                         "UPDATE in_auto_jbk_key SET auto = 0 WHERE id = '$id'"
1493                 );
1494         }
1495
1496         $HTML .= qq {<table summary="jbktable" border=1 cellspacing=0>\n<tr>\n};
1497         $HTML .= qq {<th>ID</th>\n};
1498         $HTML .= qq {<th>キーワード</th>\n};
1499         $HTML .= qq {<th>自動録画</th>\n};
1500         $HTML .= qq {<th>切り替え</th>\n};
1501         $HTML .= qq {<th>削除</th>\n};
1502         $HTML .= qq {</tr>\n};
1503
1504         my $ary_ref = $dbh->selectall_arrayref(
1505                 "SELECT id, keyword, auto
1506                 FROM in_auto_jbk_key
1507                 ORDER BY id " );
1508
1509         foreach my $line ( @{ $ary_ref } ) {
1510                 my $delurl = "rectool.pl?mode=jbk&amp;mode_sub=del&amp;id=$line->[0]";
1511                 my $auto = $line->[2] ? 'on' : 'off';
1512                 my $oppo = $line->[2] ? 'off' : 'on';
1513                 my $oppourl = "rectool.pl?mode=jbk&amp;mode_sub=$oppo&amp;id=$line->[0]";
1514                 $oppo .= "にする";
1515
1516                 $HTML .= qq {<tr align="center">\n};
1517                 $HTML .= qq {<td>$line->[0]</td>\n};
1518                 $HTML .= qq {<td>$line->[1]</td>\n};
1519                 $HTML .= qq {<td>$auto</td>\n};
1520                 $HTML .= qq {<td><a href="$oppourl">$oppo</a></td>\n};
1521                 $HTML .= qq {<td><a href="$delurl">削除</a></td>\n};
1522                 $HTML .= qq {</tr>\n};
1523         }
1524
1525         $HTML .= qq {</table>\n};
1526
1527         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1528         $HTML .= qq {<div>\n};
1529         $HTML .= qq {<input type="hidden" name="mode" value="jbk">\n};
1530         $HTML .= qq {<input type="hidden" name="mode_sub" value="add">\n};
1531         $HTML .= qq {<input name="keyword" type="text">\n};
1532         $HTML .= qq {<input type="submit" value="追加">\n</div>\n</form>\n<br>\n};
1533
1534         $HTML .= qq {<table summary="jbkrestable" border=1 cellspacing=0>\n<tr>\n};
1535         $HTML .= qq {<th>ID</th>\n};
1536         $HTML .= qq {<th>チャンネル</th>\n};
1537         $HTML .= qq {<th>タイトル</th>\n};
1538         $HTML .= qq {<th>開始時刻</th>\n};
1539         $HTML .= qq {<th>終了時刻</th>\n};
1540         $HTML .= qq {<th>録画時間</th>\n};
1541         $HTML .= qq {<th>予約</th>\n};
1542         $HTML .= qq {</tr>\n};
1543
1544         $ary_ref = $dbh->selectall_arrayref(
1545                 "SELECT id, auto_timeline_keyword.chtxt, epg_ch.chname, title, btime, etime
1546                 FROM auto_timeline_keyword
1547                 INNER JOIN epg_ch ON auto_timeline_keyword.chtxt = epg_ch.chtxt "
1548                 , {Slice=>{}} );
1549
1550         foreach my $line ( @{ $ary_ref } ) {
1551                 my ( $begin, $end, $diff ) = &str2readable( $line->{btime}, $line->{etime} );
1552                 $line->{btime} =~ s/(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/$1$2$3$4$5$6/;
1553                 $line->{etime} =~ s/(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/$1$2$3$4$5$6/;
1554                 my $url = qq "rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chtxt=$line->{chtxt}&amp;start=$line->{btime}&amp;stop=$line->{etime}";
1555
1556                 $HTML .= qq {<tr align="center">\n};
1557                 $HTML .= qq {<td>$line->{id}</td>\n};
1558                 $HTML .= qq {<td>$line->{chname}</td>\n};
1559                 $HTML .= qq {<td>$line->{title}</td>\n};
1560                 $HTML .= qq {<td>$begin</td>\n};
1561                 $HTML .= qq {<td>$end</td>\n};
1562                 $HTML .= qq {<td>$diff</td>\n};
1563                 $HTML .= qq {<td><a href="$url">予約</a></td>\n};
1564                 $HTML .= qq {</tr>\n};
1565         }
1566
1567         $HTML .= qq {</table>\n};
1568
1569 }
1570
1571 ################ mode=recognize ################
1572
1573 if ( $mode eq 'recognize' ) {
1574         $HTML =~ s/%HTML_TITLE_OPT%/ - Recognizer/;
1575
1576         my $text  = $params{ 'text' };
1577         utf8::decode( $text );
1578         $chtxt = $params{ 'chtxt' };
1579         my $title = $params{ 'title' };
1580         utf8::decode( $title );
1581
1582         $HTML .= qq {<div>\n};
1583         $HTML .= qq {与えられた文字列のうち、番組の放送時刻と思われる文字列を認識します。<br>\n};
1584         $HTML .= qq {番組表が取得できない一週間以上先の予約ができます。<br>\n};
1585         $HTML .= qq {<form method="post" action="rectool.pl">\n};
1586         $HTML .= qq {<div>\n};
1587         &draw_form_channel( 'nonone' );
1588         $HTML .= qq {<input type="text" name="title" value="$title">\n};
1589         $HTML .= qq {<br>\n};
1590         $HTML .= qq {<input type="hidden" name="mode" value="recognize">\n};
1591         $HTML .= qq {<textarea name="text" cols=40 rows=4>\n$text</textarea>\n};
1592         $HTML .= qq {<input type="submit" value="実行">\n</div>\n</form>\n};
1593
1594         my $ch_list = join '|', grep /.+/, values %chtxt_0_chname;
1595         my %ch_reverse = reverse %chtxt_0_chname;
1596
1597         if ( $text ) {
1598                 my ( $year, $month, $day );
1599                 my ( $bhour, $bminute, $ehour, $eminute );
1600                 my $next_day = 0;
1601                 foreach ( split /\n/, $text ) {
1602                         my @bdate = /(\d{4}).(\d{1,2}).(\d{1,2})/;
1603                         s/(\d{4}).(\d{2}).(\d{2})//;
1604                         my @btime = /(\d{1,2})[:：](\d{1,2})/;
1605                         s/(\d{1,2})[:：](\d{2})//;
1606                         my @etime = /(\d{1,2})[:：](\d{1,2})/;
1607                         s/(\d{1,2})[:：](\d{2})//;
1608                         s/\(.*\)//;
1609                         if ( !@bdate ) {
1610                                 $bdate[0] = Time::Piece->localtime->year;
1611                                 ( $bdate[1], $bdate[2] ) = /(\d{1,2})月(\d{1,2})日/;
1612                                 s/(\d{1,2})月(\d{1,2})日//;
1613                         }
1614                         next if (!( @bdate || @btime ));
1615                         ( $year,  $month, $day ) = @bdate if ( $bdate[0] && $bdate[1] && $bdate[2] );
1616                         ( $bhour, $bminute )     = @btime if ( defined $btime[0] && defined $btime[1] );
1617                         ( $ehour, $eminute )     = @etime if ( defined $etime[0] && defined $etime[1] );
1618                         $next_day = 1 if ( /深夜/ );
1619                         my ( $ch ) = /($ch_list)/;
1620                         my $chtxt = $ch_reverse{$ch} if ( $ch && $ch_reverse{$ch} );
1621                         s/($ch_list)//;
1622
1623                         if ( $year && $month && $day && defined $bhour && defined $bminute ) {
1624                                 my $tp  = Time::Piece->strptime( "$year-$month-$day $bhour:$bminute", '%Y-%m-%d %H:%M' );
1625                                 my $etp = Time::Piece->strptime( "$year-$month-$day $ehour:$eminute", '%Y-%m-%d %H:%M' ) if ( defined $ehour && defined $eminute );
1626                                 $tp += ONE_DAY if ( $next_day );
1627                                 my $start = $tp->strftime( '%Y%m%d%H%M%S' );
1628                                 my $stop  = defined $etp ?
1629                                         $etp->strftime( '%Y%m%d%H%M%S' ) :
1630                                         ( $tp + ONE_MINUTE * 30 )->strftime( '%Y%m%d%H%M%S' );
1631                                 $title = $_ if ( !$title );
1632                                 my $url = qq "rectool.pl?mode=confirm&amp;mode_sub=reserve&amp;chtxt=$chtxt&amp;start=$start&amp;stop=$stop&amp;title=$title";
1633                                 $HTML .= qq {認識結果:$year-$month-$day $bhour:$bminute -> $ehour:$eminute 残り:$_<a href="$url">リンク</a> <br>\n};
1634                         }
1635                 }
1636         }
1637 }
1638
1639 ################ mode=expert ################
1640
1641 if ( $mode eq 'expert' ) {
1642         require List::Compare;
1643
1644         my $ary_ref;
1645
1646         $HTML =~ s/%HTML_TITLE_OPT%/ - Expert/;
1647         $HTML .= qq {<div>\n};
1648
1649         if ( $mode_sub eq 'reget' ) {
1650                 my $bctype = $params{ 'bctype' };
1651                 my ( $chtxt, $chname ) = $dbh->selectrow_array(
1652                         "SELECT chtxt, chname FROM epg_ch
1653                         WHERE bctype = '$bctype' " );
1654                 $HTML .= "Update for $chname ( chtxt: $chtxt ) has been reserved.<br>\n";
1655                 $dbh->do( "UPDATE epg_ch SET status = '2' WHERE chtxt = '$chtxt' " );
1656                 goto end;
1657         }
1658
1659
1660         my @ary = $dbh->selectrow_array(
1661                 "SELECT auto_jbk, auto_bayes, auto_del_tmp, auto_opt
1662                 FROM in_settings " );
1663         my $opt = pop @ary;
1664         @ary = map( $_ ? 'checked' : '', @ary );
1665
1666         $HTML .= qq {内部オプションの変更\n<br>};
1667         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1668         $HTML .= qq {<div>\n};
1669         $HTML .= qq {<input type="hidden" name="mode"     value="change">\n};
1670         $HTML .= qq {<input type="hidden" name="mode_sub" value="setting">\n};
1671         $HTML .= qq {<input type="checkbox" name="jbk"     value="1" $ary[0]>自動地引\n};
1672         $HTML .= qq {<input type="checkbox" name="bayes"   value="1" $ary[1]>自動ベイズ\n};
1673         $HTML .= qq {<input type="checkbox" name="del_tmp" value="1" $ary[2]>自動一時ファイル削除\n};
1674         $HTML .= qq {自動オプション:<input type="text" name="opt" value="$opt">\n};
1675         $HTML .= qq {<input type="submit" value="保存">\n</div>\n</form>\n};
1676
1677
1678         $HTML .= qq {<hr>\n番組表のカテゴリ一覧と内蔵のカテゴリ一覧の合致を確認中...\n};
1679         $ary_ref = $dbh->selectcol_arrayref(
1680                 "SELECT DISTINCT category FROM epg_timeline"
1681         );
1682         my @category = sort values %category;
1683         if ( List::Compare->new( $ary_ref, \@category )->get_symdiff ) {
1684                 $HTML .= qq {一致しません<br>\n};
1685                 $HTML .= qq {番組表：@{$ary_ref}<br>\n内蔵：@category<br>\n};
1686         }
1687         else {
1688                 $HTML .= qq {一致しました<br>\n};
1689         }
1690
1691
1692         @ary = $dbh->selectrow_array( "SELECT terec, bscsrec, b252ts, ts2avi FROM in_status" );
1693         $HTML .= qq {<hr>\n地上波録画数：$ary[0]\n衛星波録画数：$ary[1]\n解読数：$ary[2]\n縁故数：$ary[3]\n<br>\n};
1694         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1695         $HTML .= qq {<div>\n};
1696         $HTML .= qq {<input type="hidden" name="mode"     value="change">\n};
1697         $HTML .= qq {<input type="hidden" name="mode_sub" value="fixstatus">\n};
1698         $HTML .= qq {<input type="submit" name="terec"   value="地上波録画数をリセット">\n};
1699         $HTML .= qq {<input type="submit" name="bscsrec" value="衛星波録画数をリセット">\n};
1700         $HTML .= qq {<input type="submit" name="b252ts"  value="解読数をリセット">\n};
1701         $HTML .= qq {<input type="submit" name="ts2avi"  value="縁故数をリセット">\n</div>\n</form>\n};
1702
1703
1704         $HTML .= qq {<hr>\nRec10 バージョン：$rec10_version\nrectool バージョン：$rectool_version\n<br>\n};
1705
1706
1707         $HTML .= qq {<hr>\n番組表の欠落<br>\n};
1708         $ary_ref = $dbh->selectall_arrayref( "SELECT chname, chtxt FROM epg_ch" );
1709         foreach my $line ( @{$ary_ref} ) {
1710                 my $ary_ref = $dbh->selectall_arrayref(
1711                         "SELECT start, stop, title FROM epg_timeline WHERE channel = '$line->[1]' ORDER BY start"
1712                 );
1713                 my $error;
1714                 my @program_old = ( '', $ary_ref->[0]->[0] );
1715                 my $program_old = \@program_old;
1716
1717                 foreach my $program_new ( @{$ary_ref} ) {
1718                         if ( $program_old->[1] ne $program_new->[0] &&
1719                                 $program_old->[2] !~ /クロ?ジング|クロージング|エンディング|休止|ミッドナイト|ending/ &&
1720                                 $program_new->[2] !~ /オープニング|ウィークリー・インフォメーション|モーニング|opening/ &&
1721                                 ( str2datetime( $program_new->[0] ) - str2datetime( $program_old->[1] ) )->delta_minutes > 30 ) {
1722                                 $program_old->[1] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1723                                 $program_new->[0] =~ s/(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/$1-$2-$3 $4:$5:$6/;
1724                                 $error .= qq{    $program_old->[2]    $program_old->[1]\n    ->  $program_new->[2]    $program_new->[0]\n};
1725                         }
1726                         $program_old = $program_new;
1727                 }
1728                 $HTML .= qq {<pre>\n$line->[0]\n$error</pre>\n} if ( $error );
1729                 }
1730
1731
1732         $ary_ref = $dbh->selectall_arrayref(
1733                 "SELECT chname, chtxt, bctype, ch, csch, updatetime, status, visible
1734                 FROM epg_ch
1735                 ORDER BY bctype " );
1736         $HTML .= qq {<hr>\n番組表の更新状況<br>\n};
1737         $HTML .= qq {<table summary="channeltable" border=1 cellspacing=0>\n<tr>\n};
1738         $HTML .= qq {<th>チャンネル名</th>\n};
1739         $HTML .= qq {<th>chtxt</th>\n};
1740         $HTML .= qq {<th>bctype</th>\n};
1741         $HTML .= qq {<th>ch</th>\n};
1742         $HTML .= qq {<th>csch</th>\n};
1743         $HTML .= qq {<th>最終更新時刻</th>\n};
1744         $HTML .= qq {<th>状態</th>\n};
1745         $HTML .= qq {<th>表示</th>\n};
1746         $HTML .= qq {</tr>\n};
1747         foreach my $status ( @{$ary_ref} ) {
1748                 $HTML .= qq {<tr>\n};
1749                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1750                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1751                 $HTML .= qq {</tr>\n};
1752         }
1753         $HTML .= qq {</table>\n};
1754
1755         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1756         $HTML .= qq {<div>\n};
1757         $HTML .= qq {番組表を再取得する\n};
1758         $HTML .= qq {<input type="hidden" name="mode" value="expert">\n};
1759         $HTML .= qq {<input type="hidden" name="mode_sub" value="reget">\n};
1760         $HTML .= qq {<select name="bctype">\n};
1761         $ary_ref = $dbh->selectall_arrayref(
1762                 "SELECT chname, bctype
1763                 FROM epg_ch WHERE bctype NOT LIKE '_s%' "
1764         );
1765         foreach my $line ( @{$ary_ref} ) {
1766                 $HTML .= qq {<option value="$line->[1]">$line->[0]</option>\n};
1767         }
1768         $HTML .= qq {<option value="bs">BS</option>\n};
1769         $HTML .= qq {<option value="cs1">CS1</option>\n};
1770         $HTML .= qq {<option value="cs2">CS2</option>\n};
1771         $HTML .= qq {</select>\n};
1772         $HTML .= qq {<input type="submit" value="実行">\n</div>\n</form>\n};
1773
1774
1775
1776         $ary_ref = $dbh->selectall_arrayref(
1777                 "SELECT id, type, chtxt, title, btime, etime, opt, deltaday, deltatime
1778                 FROM timeline
1779                 ORDER BY id ");
1780         $HTML .= qq {<hr>\n予約表<br>\n};
1781         $HTML .= qq {<table summary="rectimetable" border=1 cellspacing=0>\n<tr>\n};
1782         $HTML .= qq {<th>ID</th>\n};
1783         $HTML .= qq {<th>type</th>\n};
1784         $HTML .= qq {<th>chtxt</th>\n};
1785         $HTML .= qq {<th>title</th>\n};
1786         $HTML .= qq {<th>btime</th>\n};
1787         $HTML .= qq {<th>etime</th>\n};
1788         $HTML .= qq {<th>opt</th>\n};
1789         $HTML .= qq {<th>deltaday</th>\n};
1790         $HTML .= qq {<th>deltatime</th>\n};
1791         $HTML .= qq {</tr>\n};
1792         foreach my $status ( @{$ary_ref} ) {
1793                 $HTML .= qq {<tr>\n};
1794                 $HTML .= qq {<td>$status->[0]</td>\n<td>$status->[1]</td>\n<td>$status->[2]</td>\n<td>$status->[3]</td>\n};
1795                 $HTML .= qq {<td>$status->[4]</td>\n<td>$status->[5]</td>\n<td>$status->[6]</td>\n<td>$status->[7]</td>\n};
1796                 $HTML .= qq {<td>$status->[8]</td>\n};
1797                 $HTML .= qq {</tr>\n};
1798         }
1799         $HTML .= qq {</table>\n};
1800 }
1801
1802 ################ mode=log ################
1803
1804 if ( $mode eq 'log' ) {
1805         $HTML =~ s/%HTML_TITLE_OPT%/ - Log/;
1806
1807         $HTML .= qq {<div>\n};
1808         $HTML .= qq {<table summary="reclogtable" border=1 cellspacing=0>\n<tr>\n};
1809         $HTML .= qq {<th>ID</th>\n};
1810         $HTML .= qq {<th>chtxt</th>\n};
1811         $HTML .= qq {<th>title</th>\n};
1812         $HTML .= qq {<th>btime</th>\n};
1813         $HTML .= qq {<th>etime</th>\n};
1814         $HTML .= qq {<th>opt</th>\n};
1815         $HTML .= qq {<th>exp</th>\n};
1816         $HTML .= qq {<th>longexp</th>\n};
1817         $HTML .= qq {<th>category</th>\n};
1818         $HTML .= qq {</tr>\n};
1819         $ary_ref = $dbh->selectall_arrayref(
1820                 "SELECT id, chtxt, title, btime, etime, opt, exp, longexp, category
1821                 FROM in_timeline_log "
1822         );
1823         foreach my $line ( @{$ary_ref} ) {
1824                 $HTML .= qq {<tr>\n};
1825                 $HTML .= qq {<td>$line->[0]</td>\n<td>$line->[1]</td>\n<td>$line->[2]</td>\n<td>$line->[3]</td>\n};
1826                 $HTML .= qq {<td>$line->[4]</td>\n<td>$line->[5]</td>\n<td>$line->[6]</td>\n<td>$line->[7]</td>\n};
1827                 $HTML .= qq {<td>$line->[8]</td>\n};
1828                 $HTML .= qq {</tr>\n};
1829         }
1830         $HTML .= qq {</table>\n};
1831 }
1832
1833 ################ mode=help ################
1834
1835 if ( $mode eq 'help' ) {
1836         $HTML =~ s/%HTML_TITLE_OPT%/ - Help/;
1837         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1838         $HTML .= qq {<div>\n};
1839         $HTML .= qq {ヘルプ\n};
1840 }
1841
1842 ################ mode=test ################
1843
1844 if ( $mode eq 'test' ) {
1845         $HTML =~ s/%HTML_TITLE_OPT%/ - Test/;
1846         $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
1847         $HTML .= qq {<div>\n};
1848
1849         require Data::Dumper;
1850         $tmp = Perl6::Slurp::slurp( 'config.ini' );
1851         $tmp =~ s/\n/<br>\n/gs;
1852         $HTML .= $tmp;
1853
1854         # $HTML .= Dumper( $ary_ref );
1855 }
1856
1857 ################ mode nasi ################
1858
1859 if ( !$mode ) {
1860         &draw_form();
1861         $HTML =~ s/%HTML_TITLE_OPT%/ - Top/;
1862         $HTML .= qq {Welcome to Rec10!<br>\n};
1863         goto end;
1864 }
1865
1866
1867 end:
1868 #<div style="float: right">
1869 $HTML .= <<EOM;
1870 </div>
1871 </body>
1872 </html>
1873 EOM
1874
1875 #<div align="center">
1876 #$HTML_ADV = $HTML_ADV_IMG . $HTML_ADV_TEXT if ( !$HTML_ADV );
1877 my $HTML_ADV = '';
1878 $HTML_HEADER = qq {<div style="text-align: center">\n$HTML_ADV\n</div>\n};
1879
1880 &draw_menu();
1881 $HTML =~ s/%HTML_TITLE_OPT%//;
1882 $HTML =~ s/%REFRESH%//;
1883 $HTML =~ s/%SCRIPT%//;
1884 $HTML =~ s/%CSS%//;
1885 $HTML =~ s/%HTML_HEADER%/$HTML_HEADER/;
1886
1887 utf8::encode( $HTML );
1888 print $HTTP_HEADER;
1889 print $HTML;
1890 exit;
1891
1892 sub draw_menu {
1893         $hires = Time::HiRes::time() - $hires;
1894         $last_modified = localtime((stat 'rectool.pl')[9]);
1895
1896         $HTML_HEADER .= qq {<div>\n};
1897         $HTML_HEADER .= qq {<span style="float: right; font-size: 8px">Last-Modified: $last_modified<br>Time-Elapsed: $hires 秒</span>\n};
1898         $HTML_HEADER .= qq {<span style="float: left">\n};
1899         $HTML_HEADER .= qq {<a href="rectool.pl">トップ(検索)</a>\n};
1900         $HTML_HEADER .= qq {<a href="rectool.pl?mode=schedule">予約確認</a>\n};
1901         $HTML_HEADER .= qq {<a href="rectool.pl?mode=graph">予約状況(画像版)</a>\n};
1902         $HTML_HEADER .= qq {<a href="rectool.pl?mode=list">録画一覧</a>\n};
1903         $HTML_HEADER .= qq {<a href="rectool.pl?mode=bravia">おまかせ</a>\n};
1904         $HTML_HEADER .= qq {<a href="rectool.pl?mode=expert">玄人仕様</a>\n};
1905         $HTML_HEADER .= qq {<a href="rectool.pl?mode=proc">復旧支援</a>\n};
1906         $HTML_HEADER .= qq {<a href="rectool.pl?mode=jbk">地引</a>\n};
1907         $HTML_HEADER .= qq {<a href="rectool.pl?mode=log">録画履歴</a>\n};
1908         $HTML_HEADER .= qq {<a href="rectool.pl?mode=recognize">文字認識</a>\n};
1909         $HTML_HEADER .= qq {<a href="rectool.pl?mode=edit">新規予約</a>\n};
1910 #       $HTML_HEADER .= qq {<a href="../rec10web/rec10web.py">新規予約</a>\n};
1911         $HTML_HEADER .= qq {</span>\n};
1912         $HTML_HEADER .= qq {<hr style="clear: both; background-color: grey; height: 4px">\n};
1913         $HTML_HEADER .= qq {</div>\n};
1914 }
1915
1916 sub draw_form {
1917         $chname = $params{ 'chname' };
1918         $chtxt  = $params{ 'chtxt' };
1919         $key    = $params{ 'key' };
1920         utf8::decode( $key );
1921         if ( $chname ) {
1922                 $chtxt = $dbh->selectrow_array("SELECT chtxt FROM epg_ch WHERE chname = '$chname' ");
1923         }
1924
1925         $HTML .= qq {<div style="float: left">\n};
1926         $HTML .= qq {<form method="get" action="rectool.pl">\n};
1927         $HTML .= qq {<div>\n};
1928         $HTML .= qq {<input type="hidden" name="mode" value="program">\n};
1929
1930         # チャンネル指定
1931         &draw_form_channel();
1932
1933         # 日付指定
1934         $HTML .= qq {<select name="date">\n<option value="" selected>無指定</option>\n};
1935         $ary_ref = $dbh->selectcol_arrayref(
1936                 "SELECT DISTINCT SUBSTRING(start, 1, 8) FROM epg_timeline ORDER BY start"
1937         );
1938         $date_sel = $params{ 'date' };
1939         foreach my $date ( @{ $ary_ref } ) {
1940                 my @date = $date =~ /(.{4})(.{2})(.{2})/;
1941                 $date_prt = "$date[1]/$date[2]";
1942
1943                 if ( $date eq $date_sel ) {
1944                         $HTML .= qq {<option value="$date" selected>$date_prt</option>\n};
1945                 }
1946                 else {
1947                         $HTML .= qq {<option value="$date">$date_prt</option>\n};
1948                 }
1949         }
1950         $HTML .= qq {</select>\n};
1951
1952         # カテゴリ指定
1953         $HTML .= qq {<select name="category">\n<option value="" selected>無指定</option>\n};
1954         $category_sel = $params{ 'category' };
1955         foreach my $category ( keys %category ) {
1956                 if ( $category eq $category_sel ) {
1957                         $HTML .= qq {<option value="$category" selected>$category{$category}</option>\n};
1958                 }
1959                 else {
1960                         $HTML .= qq {<option value="$category">$category{$category}</option>\n};
1961                 }
1962         }
1963         $HTML .= qq {</select>\n};
1964
1965         # キーワード指定
1966         $HTML .= qq {<input name="key" type="text" value="$key" style="width:200px" accesskey="s">\n};
1967
1968         # フォーム描画
1969         $HTML .= qq {<input type="submit" value="更新" accesskey="r">\n</div>\n</form>\n};
1970 }
1971
1972 sub draw_form_channel {
1973         $HTML .= qq {<select name="chtxt">\n};
1974         $HTML .= qq {<option value="" selected>無指定</option>\n} if ( shift ne 'nonone' );
1975
1976         foreach my $key ( keys %chtxt_0_chname ) {
1977                 my $value = $chtxt_0_chname{$key};
1978                 if ( ($chtxt && $key eq $chtxt ) || ( $chname && $value eq $chname ) ) {
1979                         $HTML .= qq {<option value="$key" selected>$value</option>\n};
1980                 }
1981                 else {
1982                         $HTML .= qq {<option value="$key">$value</option>\n};
1983                 }
1984         }
1985         $HTML .= qq {</select>\n};
1986 }
1987
1988 sub draw_form_opt {
1989         my $shift = shift;
1990         my ( %selected, %checked );
1991
1992         if ( $chtxt  =~ /BS_103/ ) {
1993                 $selected{F} = 'selected';
1994         }
1995         elsif ( $chtxt  =~ /CS_239|CS_240|CS_335/ ) {
1996                 $selected{H} = 'selected';
1997         }
1998         elsif ( $chtxt =~ /BS_101|BS_102/ || $bctype =~ /cs/ ) {
1999                 $selected{W} = 'selected';
2000         }
2001         elsif ( $bctype =~ /bs|te/ ) {
2002                 $selected{H} = 'selected';
2003         }
2004         $selected{g} = 'selected';
2005         $selected{s} = 'selected';
2006         $checked{a} = $chtxt =~ /CS_331|CS_332|CS_333|CS_334|CS_335/ || $category =~ /アニメ/ ? 'checked' : '';
2007         $checked{l} = '';
2008         $checked{d} = $title =~ /\Q[二]\E|［二］|\Q(二)\E|（二）/ ? 'checked' : '';
2009         $checked{5} = $title =~ /5\.1|5．1/ ? 'checked' : '';
2010         $checked{2} = 'checked';
2011
2012         if ( $opt ) {
2013                 undef %checked;
2014                 undef %selected;
2015                 my @opt = split //, $opt;
2016                 foreach my $opt ( @opt ) {
2017                         $selected{$opt} = 'selected' if ( $opt =~ /S|L|G|H|F/ );
2018                         $checked {$opt} = 'checked'  if ( $opt =~ /a|h|l|d|2|5/ );
2019                 }
2020                 $checked{d} = $title =~ /\Q[二]\E|［二］|\Q(二)\E|（二）/ ? 'checked' : '';
2021                 $checked{5} = $title =~ /5\.1|5．1/ ? 'checked' : '';
2022         }
2023         # 画質/圧縮率ともに指定されていない場合、真ん中をselectedにする
2024         $selected{g} = 'selected' unless ( $selected{u} || $selected{i} || $selected{o} || $selected{p} );
2025         $selected{s} = 'selected' unless ( $selected{q} || $selected{w} || $selected{e} || $selected{r} );
2026
2027         $HTML .= qq {<select name="opt">\n};
2028         #$HTML .= qq {<option value="S" $selected{S}>S 720x480</option>\n};
2029         $HTML .= qq {<option value="W" $selected{W}>W 854x480</option>\n};
2030         $HTML .= qq {<option value="H" $selected{H}>H 1280x720</option>\n};
2031         $HTML .= qq {<option value="F" $selected{F}>F 1920x1080</option>\n};
2032         $HTML .= qq {<option value="I" $selected{I}>I インタレ保持</option>\n};
2033         $HTML .= qq {</select>\n};
2034
2035         $HTML .= qq {<select name="opt">\n};
2036         $HTML .= qq {<option value="u" $selected{u}>最低</option>\n};
2037         $HTML .= qq {<option value="i" $selected{i}>低</option>\n};
2038         $HTML .= qq {<option value=""  $selected{g}>画質</option>\n};
2039         $HTML .= qq {<option value="o" $selected{o}>高</option>\n};
2040         $HTML .= qq {<option value="p" $selected{p}>最高</option>\n};
2041         $HTML .= qq {</select>\n};
2042
2043         $HTML .= qq {<select name="opt">\n};
2044         $HTML .= qq {<option value="q" $selected{q}>最低</option>\n};
2045         $HTML .= qq {<option value="w" $selected{w}>低</option>\n};
2046         $HTML .= qq {<option value=""  $selected{s}>圧縮率</option>\n};
2047         $HTML .= qq {<option value="e" $selected{e}>高</option>\n};
2048         $HTML .= qq {<option value="r" $selected{r}>最高</option>\n};
2049         $HTML .= qq {</select>\n};
2050
2051         $HTML .= qq {<select name="opt">\n};
2052         $HTML .= qq {<option value=""  $selected{s}>コンテナ</option>\n};
2053         $HTML .= qq {<option value="m" $selected{e}>MKV</option>\n};
2054         $HTML .= qq {<option value="4" $selected{r}>MP4</option>\n};
2055         $HTML .= qq {</select>\n};
2056
2057         $HTML .= qq {<select name="opt">\n};
2058         $HTML .= qq {<option value=""  $selected{s}>モバイル向け</option>\n};
2059         $HTML .= qq {<option value="1" $selected{e}>QVGA</option>\n};
2060         $HTML .= qq {<option value="2" $selected{r}>WVGA</option>\n};
2061         $HTML .= qq {</select>\n};
2062
2063         $HTML .= qq {<input type="checkbox" name="opt" value="a" $checked{a}>24fps(主にアニメ)\n};
2064         $HTML .= qq {<input type="checkbox" name="opt" value="d" $checked{d}>二ヶ国語放送\n};
2065         #$HTML .= qq {<input type="checkbox" name="opt" value="2" $checked{2}>2passモード\n};
2066         $HTML .= qq {<input type="checkbox" name="opt" value="5" $checked{5}>5.1ch放送\n};
2067         $HTML .= qq {<br>\n};
2068         $HTML .= qq {<select name="opt">\n};
2069         $HTML .= qq {<option value="">移動なし</option>\n};
2070         $HTML .= qq {<option value="R">録画後移動</option>\n};
2071         $HTML .= qq {<option value="D">解読後移動</option>\n};
2072         $HTML .= qq {<option value="E">縁故後移動</option>\n};
2073         $HTML .= qq {</select>\n};
2074         $HTML .= qq {<input type="checkbox" name="opt"   value="N">ファイル名日時追加\n} if ( $shift eq 'reserve' );
2075         $HTML .= qq {<input type="checkbox" name="every" value="1">隔週録画\n}           if ( $shift eq 'reserve' );
2076 }
2077
2078 sub parse_program {
2079         $chname  = $params{ 'chname' };
2080         $chtxt   = $params{ 'chtxt' };
2081         $start   = $params{ 'start' };
2082         $stop    = $params{ 'stop' };
2083         $bayesid = $params{ 'bayesid' };
2084         $id      = $params{ 'id' };
2085
2086         if ( $chname ) {
2087                 $chtxt = $dbh->selectrow_array("SELECT chtxt FROM epg_ch WHERE chname = '$chname'");
2088         }
2089         elsif ( $chtxt && $chtxt_0_chname{$chtxt} ) {
2090                 $chname = $chtxt_0_chname{$chtxt};
2091                 ( $chtxt_sql = $chtxt ) =~ s/_0/_%/;
2092                 $bctype = $dbh->selectrow_array("SELECT bctype FROM epg_ch WHERE chtxt LIKE '$chtxt_sql'");
2093         }
2094         elsif ( $chtxt ) {
2095                 $chname = $dbh->selectrow_array("SELECT chname FROM epg_ch WHERE chtxt = '$chtxt'")
2096         }
2097         ( $title, $desc, $longdesc, $category ) = $dbh->selectrow_array(
2098                 "SELECT title, exp, longexp, category
2099                 FROM epg_timeline
2100                 WHERE channel = '$chtxt' AND start = '$start' AND stop = '$stop' ");
2101         if ( !$bctype ) {
2102                 $bctype = $dbh->selectrow_array("SELECT bctype FROM epg_ch WHERE chtxt = '$chtxt'");
2103         }
2104
2105         if ( $bayesid ) {
2106                 ( $chtxt, $title, $begin, $end ) = $dbh->selectrow_array(
2107                         "SELECT chtxt, title, btime, etime FROM auto_timeline_bayes WHERE id = '$bayesid' "
2108                 );
2109                 ( $chname, $bctype ) = $dbh->selectrow_array(
2110                         "SELECT chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
2111                 );
2112                 $start = str2datetime( $begin )->strftime( '%Y%m%d%H%M%S' );
2113                 $stop  = str2datetime( $end   )->strftime( '%Y%m%d%H%M%S' );
2114                 ( $desc, $longdesc, $category ) = $dbh->selectrow_array(
2115                         "SELECT exp, longexp, category FROM epg_timeline WHERE channel = '$chtxt' AND start = '$start' AND stop = '$stop' "
2116                 );
2117         }
2118         if ( $id ) {
2119                 ( $type, $chtxt, $title, $begin, $end, $deltaday, $deltatime, $opt, $counter ) = $dbh->selectrow_array(
2120                         "SELECT type, chtxt, title, btime, etime, deltaday, deltatime, opt, counter
2121                         FROM timeline WHERE id = '$id' "
2122                 );
2123                 ( $chname, $bctype ) = $dbh->selectrow_array(
2124                         "SELECT chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
2125                 );
2126                 $start = str2datetime( $begin )->strftime( '%Y%m%d%H%M%S' );
2127                 $stop  = str2datetime( $end   )->strftime( '%Y%m%d%H%M%S' );
2128                 ( $desc, $longdesc, $category ) = $dbh->selectrow_array(
2129                         "SELECT exp, longexp, category FROM epg_timeline WHERE channel = '$chtxt' AND start = '$start' AND stop = '$stop' "
2130                 );
2131         }
2132         if ( $bctype =~ /bs|cs/ ) {
2133                 $bctype_sql = '_s%';
2134         }
2135         elsif ( $bctype =~ /te/ ) {
2136                 ( $chtxt_0   = $chtxt ) =~ s/(\d+)_.*/$1_0/;
2137                 ( $chtxt_sql = $chtxt ) =~ s/_0/_%/;
2138                 $bctype_sql = 'te%';
2139         }
2140         #( $chtxt_no0 ) = $chtxt   =~ /(\d+)_/;
2141         @start = $start =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
2142         @stop  = $stop  =~ /(.{4})(.{2})(.{2})(.{2})(.{2})/;
2143         $begin = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @start, '00' );
2144         $end   = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', @stop , '00' );
2145
2146         if ( $params{ 'title' } ) {
2147                 $title = $params{ 'title' };
2148                 utf8::decode( $title );
2149         }
2150         $HTML .= qq {<!-- chtxt=$chtxt chtxt_0=$chtxt_0 chtxt_sql=$chtxt_sql bctype=$bctype -->\n};
2151 }
2152
2153 sub check_error {
2154         my $is_error;
2155         my $is_same = $dbh->selectrow_array(
2156                 "SELECT COUNT(*) FROM timeline WHERE chtxt = '$chtxt' AND btime = '$begin' AND etime = '$end'"
2157         );
2158         my @overlap = &get_overlap();
2159
2160         if ( $is_same ) {
2161                 $HTML .= "同一の番組が既に存在します。<br>\n";
2162                 $is_error = 1;
2163         }
2164         elsif ( $overlap[0] >= 2 ) {
2165                 $HTML .= "時間が被る番組が既に2個存在します。<br>\n";
2166                 $HTML .= $overlap[1];
2167                 $is_error = 2;
2168         }
2169         else {
2170                 $is_error = 0;
2171         }
2172         return $is_error;
2173 }
2174
2175 sub get_overlap {
2176         require List::Util;
2177
2178         my $ary_ref = $dbh->selectall_arrayref(
2179                 "SELECT btime, etime, title
2180                 FROM timeline
2181                 INNER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
2182                 WHERE bctype LIKE '$bctype_sql' AND type IN $type_user_made
2183                 AND btime < '$end'
2184                 AND etime > '$begin'
2185                 "
2186         );
2187
2188         my %overlap;
2189         my $overlap = $max = 0;
2190         my $str;
2191         foreach my $prg ( @{ $ary_ref } ) {
2192                 $str .= "$prg->[0] ? $prg->[1] : $prg->[2]<br>\n";
2193                 $overlap{$prg->[0]} += 1;
2194                 $overlap{$prg->[1]} -= 1;
2195         }
2196         foreach my $key ( sort keys %overlap ) {
2197                 $overlap += $overlap{$key};
2198                 $max = List::Util::max( $max, $overlap );
2199         }
2200         if ( wantarray ) {
2201                 return ( $max, $str );
2202         }
2203         else {
2204                 return $max;
2205         }
2206 }
2207
2208 sub get_file_list_wrapper {
2209         local $base_dir = shift;
2210         local $ptr = shift;
2211
2212         &get_file_list( $base_dir );
2213 }
2214
2215 sub get_file_list{
2216         my $dir = shift;
2217
2218         opendir ( DIR, $dir );
2219         my @list = sort readdir( DIR );
2220         closedir( DIR );
2221
2222         foreach my $file ( @list ) {
2223                 next if ( $file =~ /^\.{1,2}$/ );
2224                 if ( -d "$dir/$file" ){
2225                         &get_file_list("$dir/$file");
2226                 }
2227                 else{
2228                         $abs = "$dir/$file";
2229                         utf8::decode( $abs );
2230                         ( $rel ) = $abs =~ /^$base_dir\/(.*)$/;
2231                         $ptr->( $rel, $abs );
2232                 }
2233         }
2234 }
2235
2236 sub strisjoined {
2237         my $str = shift;
2238
2239         return $str =~ /.{4}-.{2}-.{2} .{2}:.{2}:.{2}/ ? 0 : 1;
2240 }
2241
2242 sub str2datetime {
2243         my $str    = shift;
2244         my @time;
2245
2246         if ( strisjoined( $str ) ) {
2247                 @time = $str =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
2248         }
2249         else {
2250                 @time = $str =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
2251         }
2252         return DateTime->new(
2253                 year   => $time[0], month     => $time[1], day    => $time[2],
2254                 hour   => $time[3], minute    => $time[4], second => $time[5],
2255                 locale => 'ja_JP' , time_zone => $tz
2256         );
2257 }
2258
2259 sub str2dayname {
2260         my  $str = shift;
2261         our %day_name_cache;
2262
2263         if ( !$day_name_cache{$str} ) {
2264                 $day_name_cache{$str} = str2datetime( $str )->day_name;
2265         }
2266         return $day_name_cache{$str};
2267 }
2268
2269 sub str2readable {
2270         my $begin = shift;
2271         my $end   = shift;
2272
2273         my $dt_begin = ref( $begin ) eq 'DateTime' ? $begin : &str2datetime( $begin );
2274         my $dt_end   = ref( $end   ) eq 'DateTime' ? $end   : &str2datetime( $end );
2275
2276         my $str_begin = $dt_begin->strftime( '%m/%d(%a) %H:%M' );
2277         my $str_end   = $dt_end  ->strftime( $dt_begin->day == $dt_end->day ? '%H:%M' : '翌 %H:%M' );
2278         # utf8::encode( $str_begin );
2279
2280         my ( $sec, $min, $hour );
2281         $sec  = $dt_end->epoch - $dt_begin->epoch;
2282         $min  = int( $sec / 60 );
2283         $sec  = $sec - $min * 60;
2284         $hour = int( $min / 60 );
2285         $min  = $min - $hour * 60;
2286         my $str_diff = '';
2287         $str_diff .= $hour . '時間' if ( $hour );
2288         $str_diff .= $min  . '分'   if ( $min );
2289         $str_diff .= $sec  . '秒'   if ( $sec );
2290
2291         return ( $str_begin, $str_end, $str_diff );
2292 }
2293
2294 sub sqlgetsuggested {
2295         require Encode;
2296         require Text::Ngram;
2297
2298         my ( $btime, $etime ) = @_;
2299         $deltatime = 3 if ( !$deltatime );
2300
2301         $btime_bgn = $btime->clone->subtract( hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
2302         $btime_end = $btime->clone->add(      hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
2303         $etime_bgn = $etime->clone->subtract( hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
2304         $etime_end = $etime->clone->add(      hours => $deltatime )->strftime( '%Y%m%d%H%M%S' );
2305
2306         $ary_ref = $dbh->selectall_arrayref(
2307                 "SELECT start, stop, title, exp
2308                 FROM epg_timeline
2309                 WHERE channel LIKE '$chtxt_sql'
2310                 AND start BETWEEN '$btime_bgn' AND '$btime_end'
2311                 AND stop  BETWEEN '$etime_bgn' AND '$etime_end' "
2312         );
2313         #die Dumper $ary_ref;
2314
2315         my %hash;
2316         my $hash_r = Text::Ngram::ngram_counts( $title, 2 ); # bi-gram
2317         foreach my $program ( @{$ary_ref} ) {
2318                 my $hash_k = Text::Ngram::ngram_counts( $program->[2], 2 );
2319                 my $point;
2320                 map $point += $hash_k->{$_}, keys %{$hash_r};
2321                 push @{$hash{$point}}, $program if ( $point );
2322         }
2323
2324         return %hash;
2325 }