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