rectool/trunk/rectool.pl

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