8 #Date_Init("TZ=JST","ConvTZ=JST");
\r
12 use Algorithm::Diff qw(LCS);
\r
15 use CGI::Carp qw( fatalsToBrowser warningsToBrowser );
\r
23 use Sort::Naturally;
\r
28 #require SVG Time::Simple XML::Atom Encode Text::Ngram List::Compare List::Util
\r
30 #%DB::packages = ( 'main' => 1 );
\r
33 ################ バージョン定義 ################
\r
36 my $rectool_version = 101;
\r
39 ################ 初期化ここから ################
\r
42 my $tz = DateTime::TimeZone->new( name => 'local' );
\r
43 my $hires = Time::HiRes::time();
\r
45 my $cfg = new Config::Simple;
\r
46 if ( -e 'rec10.conf' ) {
\r
47 $cfg->read( 'rec10.conf' );
\r
49 elsif ( -e '/etc/rec10.conf' ) {
\r
50 $cfg->read( '/etc/rec10.conf' );
\r
53 die 'rec10.confが見つかりません。';
\r
56 my $sql = $cfg->param( 'db.db' );
\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
67 mysql_enable_utf8 => 1, # only availavle for MySQL
\r
69 $dbh->do( 'SET NAMES utf8' );
\r
72 my $rec10_version = eval {
\r
73 $dbh->selectrow_array( "SELECT version FROM in_status " );
\r
78 $HTTP_HEADER = "Content-Type: text/html\n\n";
\r
80 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
\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
98 my ( $user, $pass, $auth );
\r
99 ( $user, $pass ) = eval {
\r
100 $dbh->selectrow_array( "SELECT webuser, webpass FROM in_settings " );
\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
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
127 if ( $rec10_version != $rectool_version ) {
\r
128 $HTML .= qq {<div style="font-size: 200%; font-weight: bold; color: red">\n};
\r
130 if ( $rec10_version > $rectool_version ) {
\r
131 $HTML .= qq {Rec10本体のバージョンが新しいため、実行できません。<br>\n};
\r
132 $HTML .= qq {rectoolのバージョンアップを行ってください。<br>\n};
\r
135 if ( $rec10_version < $rectool_version ) {
\r
136 $HTML .= qq {Rec10本体のバージョンが古いため、実行できません。<br>\n};
\r
137 $HTML .= qq {Rec10のバージョンアップを行ってください。<br>\n};
\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
146 %params = $q->Vars;
\r
147 $mode = $params{ 'mode' };
\r
148 $mode_sub = $params{ 'mode_sub' };
\r
150 ################ %chtxt_chnameの準備 ################
\r
153 my %chtxt_0_chname;
\r
154 tie %chtxt_0_chname, 'Tie::IxHash';
\r
156 my $ary_ref = $dbh->selectall_arrayref(
\r
157 "SELECT chtxt, chname, ch, bctype FROM epg_ch
\r
161 %chtxt_chname = map { $_->[0], $_->[1] } @{$ary_ref};
\r
163 # NHK BS 1/2/hiをBS/CSから除外(101-103) - by 2011/04
\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
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
176 push @{ $chtxt_0_chname{'BS_' . $line->[2] } }, $line->[1];
\r
179 foreach my $key ( keys %chtxt_0_chname ) {
\r
180 my @chname = @{ $chtxt_0_chname{$key} };
\r
181 if ( @chname >= 2 ) {
\r
183 my @tmp = map { my @ary = split //, $_; \@ary } @chname;
\r
185 # FIXME: すべてを比較するべき
\r
186 $chtxt_0_chname{$key} = join '', LCS( $tmp[0], $tmp[1] );
\r
190 $chtxt_0_chname{$key} = $chname[0];
\r
195 foreach my $line ( @bc_ary ) {
\r
196 $chtxt_0_chname{$line->[0]} = $line->[1];
\r
201 ################ 定数宣言 ################
\r
204 tie %type, 'Tie::IxHash';
\r
206 'search_everyday' => '隔日検索',
\r
207 'search_today' => '当日検索',
\r
208 'reserve_flexible' => '浮動予約',
\r
209 'reserve_fixed' => '確定予約',
\r
211 'reserve_running' => '録画途中',
\r
213 'convert_b25_ts' => '解読予約',
\r
214 'convert_b25_ts_running' => '解読途中',
\r
215 'convert_b25_ts_miss' => '解読失敗',
\r
217 'convert_ts_mp4' => '縁故予約',
\r
218 'convert_ts_mp4_running' => '縁故於鯖',
\r
219 'convert_ts_mp4_network' => '縁故於網',
\r
220 'convert_ts_mp4_finished' => '縁故完了',
\r
222 'convert_avi_mkv' => '変換旧露',
\r
223 'convert_avi_mp4' => '変換旧四',
\r
224 'convert_mkv_mp4' => '変換露四',
\r
225 'convert_mkv_mp4_runnings' => '換途露四',
\r
227 'auto_suggest_dec' => '予測解読',
\r
228 'auto_suggest_enc' => '予測縁故',
\r
229 'auto_suggest_avi2fp' => '予測旧四',
\r
230 'auto_suggest_ap2fp' => '予測露四',
\r
232 'move_end' => '移動完了',
\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
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
254 'other' => '#A0A0A0',
\r
257 $type_user_made = "( 'search_everyday', 'search_today', 'reserve_flexible', 'reserve_fixed', 'reserve_running' )";
\r
259 tie %category, 'Tie::IxHash';
\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
275 ################ 初期化ここまで ################
\r
278 ################ mode=schedule ################
\r
280 if ( $mode eq 'schedule' ) {
\r
282 $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Viewer/;
\r
283 #$HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="300">|;
\r
285 <style type="text/css">
\r
287 white-space: nowrap;
\r
291 $css =~ s/^\t{2}//gm;
\r
292 $HTML =~ s/%CSS%/$css/;
\r
294 my $order = $params{ 'order' };
\r
295 my $extra = $params{ 'extra' };
\r
296 if ( $order ne 'id' ) {
\r
299 $reverse_extra = $extra ? '' : '&extra=1';
\r
300 $forward_order = $order eq 'btime' ? '' : '&order=id';
\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
306 LEFT OUTER JOIN epg_ch ON timeline.chtxt = epg_ch.chtxt
\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&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
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
337 my $color = $color{$line->{type}} ? $color{$line->{type}} : $color{'other'};
\r
338 $type = qq {<span style="color: $color">$type</span>};
\r
340 # 地上波の場合、xx_yyyをxx_0に置換する
\r
341 ( $line->{chtxt_0} = $line->{chtxt} ) =~ s/(\d+)_/$1_0/;
\r
342 # chnameが無いとき(移動縁故など)、chtxtを代わりに使う
\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
353 $line->{chname_link} = qq {<a href="rectool.pl?mode=program&chtxt=$line->{chtxt}">$line->{chname}</a>};
\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
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
373 $epgtitle =~ s/無料≫//;
\r
375 if ( $epgtitle ne $line->{title} ) {
\r
376 # epgtitleとtitleが一致しない
\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
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&id=$line->{id}&suggest=auto">自動検索</a>};
\r
390 $epgtitle = qq {<span style="color: #FF4000">$epgtitle■$href■</span>};
\r
393 # epgtitleにtitleが含まれている
\r
394 $epgtitle = $epgtitle_nobrackets;
\r
398 # epgtitleとtitleが一致している
\r
402 $line->{title_2} = qq {<div style="float: right; cursor: help" title="$epgexp">$epgtitle</div>};
\r
406 my $href = qq {<a href="rectool.pl?mode=edit&id=$line->{id}&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
412 my ( $begin, $end, $diff ) = &str2readable( $unix_b, $unix_e );
\r
416 $line->{type} eq 'reserve_running'
\r
418 $unix_b->epoch <= time && time <= $unix_e->epoch
\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
426 $line->{title} = qq {<a href="rectool.pl?mode=edit&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
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
445 ################ mode=graph ################
\r
447 if ( $mode eq 'graph' ) {
\r
449 my $date = $params{ 'date' };
\r
453 print "Content-Type: image/svg+xml\n\n";
\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
460 $today = $date eq Date::Simple->today() ? 1 : 0;
\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
466 $width = 30 * $hours;
\r
467 my %category_color = map { $_->{name}, $_->{color} } values %category;
\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
478 for ( 1..$tuner{satellite} ) {
\r
479 $svg->text( 'x' => 10, 'y' => ( $_ + $tuner{terrestrial} + 1 ) * 20 )
\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
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
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
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
509 '$graph_bgn 00:00' <= btime AND btime < '$graph_end 00:00'
\r
511 '$graph_bgn 00:00' < etime AND etime <= '$graph_end 00:00'
\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
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
537 $line->{slot} = $i;
\r
538 $y_drawn[$i] = $line->{etime};
\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
550 if ( $r + $g + $b == 0 ){
\r
551 $r = $g = $b = 128;
\r
553 my %escaped = ( '&' => 'amp', '<' => 'lt', '>' => 'gt', '"' => 'quot' );
\r
555 my $str = shift or return;
\r
557 $result .= $escaped{$_} ? '&' . $escaped{$_} . ';' : $_
\r
558 for (split //, $str);
\r
562 -href => "rectool.pl?mode=edit&id=$line->{id}",
\r
563 target => '_blank',
\r
564 -title => html_escape( $line->{title} ),
\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
570 style => { fill => $category_color{$line->{epgcategory}} || $category_color{'その他'} } );
\r
571 #style => { fill => "rgb($r,$g,$b)" } );
\r
574 my $xml = $svg->xmlify;
\r
575 utf8::encode( $xml );
\r
577 #warningsToBrowser(true);
\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
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
594 $ary_ref = $dbh->selectcol_arrayref(
\r
595 "SELECT DISTINCT DATE( btime )
\r
597 WHERE type in $type_user_made
\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
606 $HTML .= qq {<object type="image/svg+xml" data="rectool.pl?mode=graph&date=$date" width="820">\n};
\r
607 $HTML .= qq {SVG Image $date\n</object>\n<br>\n};
\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
616 foreach my $line ( @{ $ary_ref } ) {
\r
617 #$HTML .= qq {$line->[0] $line->[1] $line->[2] $line->[3]<br>\n};
\r
626 ################ mode=atom ################
\r
628 if ( $mode eq 'atom' ) {
\r
629 require XML::Atom::Feed;
\r
630 require XML::Atom::Entry;
\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
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
642 $ary_ref = $dbh->selectall_arrayref(
\r
643 "SELECT chtxt, title, btime, etime, opt
\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
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
660 my $feed = XML::Atom::Feed->new( Version => 1.0 );
\r
661 $feed->title('Rec10 フィード');
\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
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
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
684 my $xml = $feed->as_xml;
\r
685 print "Content-Type: application/atom+xml\n\n";
\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
698 ################ mode=edit ################
\r
700 if ( $mode eq 'edit' ) {
\r
701 my $id = $params{ 'id' };
\r
703 $HTML =~ s/%HTML_TITLE_OPT%/ - Schedule Editor/;
\r
704 $HTML .= qq {<div style="float: left">\n};
\r
707 <script type="text/javascript" src="http://www.enjoyxstudy.com/javascript/dateformat/dateformat.js">
\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
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
728 function setSuggest(start, stop){
\r
729 document.reserve.begin.value = start;
\r
730 document.reserve.end.value = stop;
\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
740 $script =~ s/^\t{2}//gm;
\r
741 $HTML =~ s/%SCRIPT%/$script/;
\r
743 $HTML .= "スケジュール編集画面です。<br>\n";
\r
744 $HTML .= "実装がとても適当なので、利用には細心の注意を払ってください。<br>\n<br>\n";
\r
748 $button_bgn = $button_end = '';
\r
752 $type = 'reserve_flexible';
\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
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
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
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
773 my %hash = &sqlgetsuggested( $btime, $etime );
\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
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
796 $HTML .= qq {</table>\n<br>\n};
\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
813 $HTML .= qq {<option value="$key">$value</option>\n};
\r
816 $HTML .= qq {</select>\n};
\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
826 $HTML .= qq {<option value="$key">$chtxt_0_chname{$key}</option>\n};
\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
842 ################ mode=change ################
\r
844 if ( $mode eq 'change' ) {
\r
845 @id = $q->param( 'id' );
\r
847 $HTML =~ s/%HTML_TITLE_OPT%/ - Change/;
\r
848 $HTML .= qq {<div style="float: left">\n};
\r
850 if ( $params{ 'delete' } )
\r
853 foreach my $id ( @id ) {
\r
854 $dbh->do( "DELETE FROM timeline WHERE id = '$id'" );
\r
856 $HTML .= "削除しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
\r
857 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
\r
861 if ( $params{ 'update' } )
\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
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
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
887 $HTML .= "更新しました。<br>\n5秒後に予約確認画面に移動します。<br>\n";
\r
888 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl?mode=schedule">|;
\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
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
905 "INSERT INTO timeline ( type, chtxt, title, btime, etime, opt )
\r
906 VALUES ( '$sql_type', '$chtxt', '$title', '$begin', '$end', '$opt' )"
\r
911 if ( $mode_sub eq 'move' ) {
\r
912 my $mode_sub2 = $params{ 'mode_sub2' };
\r
913 my $title = $params{ 'title' };
\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
921 elsif ( $mode_sub2 eq 'exec' ) {
\r
922 eval '$response = `python26 ' . $cfg->param( 'path.rec10' ) . "/classify.py -e '$title'`";
\r
924 utf8::decode( $response );
\r
925 $HTML .= $response;
\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
938 "UPDATE in_settings SET auto_jbk = '$jbk', auto_bayes = '$bayes',
\r
939 auto_del_tmp = '$del_tmp', auto_opt = '$opt'"
\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
949 "UPDATE in_status SET $key = 0"
\r
957 ################ mode=confirm ################
\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
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
968 $longdesc =~ s/\\n/<br>\n/gs;
\r
969 $HTML .= "番組内容(長):$longdesc<br>\n";
\r
971 my $error = &check_error();
\r
976 $ary_ref = $dbh->selectall_arrayref(
\r
977 "SELECT start, stop FROM epg_timeline WHERE channel = '$chtxt' AND title = '$title' "
\r
979 if ( $error != 1 ) {
\r
980 $HTML .= "同一の番組の他の放送予定です。<br>\n";
\r
981 foreach my $line ( @{$ary_ref} ) {
\r
982 $begin = $line->[0];
\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&mode_sub=reserve&chtxt=$chtxt&start=$line->[0]&stop=$line->[1]">可能</a>};
\r
988 $HTML .= "開始:$begin\n終了:$end\n録画は$overlap<br>\n";
\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
1005 # End of $mode_sub eq 'reserve';
\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
1014 $HTML .= "詳細設定を行ってください。<br>\n";
\r
1015 $HTML .= "タイトル:$title\n<br>\n";
\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
1024 $HTML .= qq {<input type="submit" value="予約">\n</form>\n};
\r
1029 ################ mode=reserve ################
\r
1031 if ( $mode eq 'reserve' ) {
\r
1032 $HTML .= qq {<div style="float: left">\n};
\r
1034 $title = $params{ 'title' } if ( !$title );
\r
1035 @opt = $q->param( 'opt' );
\r
1036 $opt = join '', @opt;
\r
1037 my ( $deltaday, $deltatime );
\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
1057 $type = 'reserve_flexible';
\r
1059 $chtxt = $chtxt_0 if ( $chtxt_0 );
\r
1060 if ( !&check_error ) {
\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
1066 $HTML .= "録画予約を実行しました。<br>\n5秒後にトップへ移動します。<br>\n";
\r
1067 $HTML =~ s|%REFRESH%|<meta http-equiv="refresh" content="5; url=rectool.pl">|;
\r
1071 ################ mode=program ################
\r
1073 if ( $mode eq 'program' ) {
\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
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
1086 if ( $chtxt =~ /^\d+(_0)?$/ ) {
\r
1087 # teはxx_yyy形式であるため
\r
1089 $ch = "AND channel LIKE '$chtxt\_%'";
\r
1092 $ch = "AND channel = '$chtxt'";
\r
1094 $sql =~ s/%CH%/$ch/;
\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
1102 if ( $category_sel ) {
\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
1109 my $key = "AND TITLE LIKE '%$key%'";
\r
1110 $sql =~ s/%KEY%/$key/;
\r
1113 $sql =~ s/%DATE%//;
\r
1114 $sql =~ s/%KEY%//;
\r
1115 $sql =~ s/%CATEGORY%//;
\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
1122 if ( $date != $prev ) {
\r
1123 my $date = DateTime->new(
\r
1124 year => $date[0], month => $date[1], day => $date[2],
\r
1128 my $dn = $date->day_name;
\r
1129 #utf8::encode( $dn );
\r
1130 $HTML .= qq {--------$date[1]/$date[2]($dn)--------<br>\n};
\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&mode_sub=reserve&chtxt=$prg->[0]&start=$prg->[2]&stop=$prg->[3]">$prg->[4]</a><br>\n};
\r
1139 ################ mode=list ################
\r
1141 if ( $mode eq 'list' ) {
\r
1142 $HTML =~ s/%HTML_TITLE_OPT%/ - List/;
\r
1143 $HTML .= qq {<div>\n};
\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
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
1156 if ( $mode_sub eq 'logzip' ) {
\r
1157 my $title = $params{ 'title' };
\r
1158 my $zip = Archive::Zip->new();
\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
1166 @lines = grep {!$count{$_}++} @lines;
\r
1167 $logzip .= join "\n", @lines;
\r
1168 $logzip .= "\n\n";
\r
1171 utf8::decode( $logzip );
\r
1172 $HTML .= '<pre>'.$logzip."</pre>\n";
\r
1175 if ( !$mode_sub ) {
\r
1176 $HTML .= qq {<a href="rectool.pl?mode=list&mode_sub=new">録画中のみ</a>\n};
\r
1177 $HTML .= qq {<a href="rectool.pl?mode=list&mode_sub=old">録画後のみ</a>\n<br>\n};
\r
1179 if ( !$mode_sub || $mode_sub eq 'new' ) {
\r
1180 $HTML .= "録画中のファイル一覧<br>\n";
\r
1181 &list( $recording );
\r
1183 if ( !$mode_sub ) {
\r
1184 $HTML .= "<br>\n";
\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
1193 local $path = shift;
\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
1200 my $exp_count = scalar keys %exp;
\r
1202 &get_file_list_wrapper( $path, \&wanted );
\r
1205 foreach my $name ( sort { $exp{$a} <=> $exp{$b} } keys %exp ) {
\r
1206 $help .= $exp{$name} + 1 . " = $name / ";
\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
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
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
1227 my $title = $q->escape( $title );
\r
1228 my $extra = qq {<td><a href="rectool.pl?mode=list&mode_sub=log&title=$title">○</a></td>\n};
\r
1230 $value->{$exp}->{extra} = $extra;
\r
1232 elsif ( $exp eq 'log.zip' ) {
\r
1234 my $title = $q->escape( $title );
\r
1235 my $extra = qq {<td><a href="rectool.pl?mode=list&mode_sub=logzip&title=$title">○</a></td>\n};
\r
1237 $value->{$exp}->{extra} = $extra;
\r
1239 elsif ( $exp eq 'mp4' ) {
\r
1241 $value->{$exp}->{style} = $value->{$exp}->{size};
\r
1243 elsif ( $exp eq 'mkv' ) {
\r
1245 my $title = $q->escape( $title );
\r
1247 my $extra = qq {<td><a title="$value->{$exp}->{size}" href="rectool.pl?mode=thumb&title=$title">■</a></td>\n};
\r
1248 $value->{$exp}->{extra} = $extra;
\r
1250 $flag[$exp{$exp}] = $value->{$exp};
\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
1258 $HTML .= qq {</tr>\n};
\r
1259 $HTML .= $help unless ( ++$count % 20 );
\r
1261 $HTML .= qq {</table>\n};
\r
1267 return if ( $rel =~ /Thumbs\.db/ );
\r
1268 return if ( $rel =~ /\.idx/ );
\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
1276 $title = '_error_exp_'.$rel;
\r
1279 if ( $title !~ /[^0-9A-F]+/ ) {
\r
1280 my $tmp = pack( 'H*', $title );
\r
1282 $title = '_error_b16_'.$rel;
\r
1286 $title = 'Base16_'.$tmp;
\r
1289 $list{$title}->{$exp} = { 'style' => $style, 'size' => $size };
\r
1296 local $path = shift;
\r
1299 &get_file_list_wrapper( $path, \&simple_wanted );
\r
1301 # @list = sort @list;
\r
1303 #@list = map( Encode::decode_utf8( $_ ), @list );
\r
1304 @list = nsort @list;
\r
1305 #@list = map( Encode::encode_utf8( $_ ), @list );
\r
1307 foreach ( @list ) {
\r
1308 $HTML .= "$_<br>\n";
\r
1311 sub simple_wanted {
\r
1315 my ( $size ) = &get_size( $abs );
\r
1316 push @list, $rel ."\t\t". $size;
\r
1322 my ( $size, $last ) = (stat( $file ))[7,9];
\r
1323 my @unim = ("B","KiB","MiB","GiB","TiB","PiB");
\r
1326 while($size >= 1024 ){
\r
1328 $size = $size / 1024;
\r
1331 $size = int( $size );
\r
1333 if ( time - $last < 10 ) {
\r
1336 elsif ( $size == 0 ) {
\r
1342 return ( "$size $unim[$count]", $style );
\r
1346 ################ mode=thumb ################
\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
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
1358 ################ mode=check ################
\r
1360 if ( $mode eq 'check' ) {
\r
1363 ################ mode=bravia ################
\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&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
1385 $order = 'point DESC';
\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
1392 foreach my $line ( @{ $ary_ref } ) {
\r
1393 my ( $begin, $end, $diff ) = &str2readable( $line->[3], $line->[4] );
\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&mode_sub=reserve&bayesid=$line->[0]">予約</a></td>\n};
\r
1403 $HTML .= qq {</tr>\n};
\r
1405 $HTML .= qq {</table>\n};
\r
1406 $HTML .= qq {</div>\n};
\r
1407 $HTML .= qq {</form>\n};
\r
1411 ################ mode=proc ################
\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
1422 my $ary_ref = $dbh->selectall_arrayref(
\r
1423 "SELECT type, chtxt, title
\r
1425 ORDER BY title " );
\r
1427 foreach my $line ( @{ $ary_ref } ) {
\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
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
1441 $url = qq {rectool.pl?mode=confirm&mode_sub=proc&type=$line->[0]&chtxt=$line->[1]&title=$line->[3]&opt=$opt};
\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
1450 $url = qq {rectool.pl?mode=confirm&mode_sub=proc&type=$line->[0]&chtxt=$line->[1]&title=$line->[3]&opt=$opt};
\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
1459 $url = qq {rectool.pl?mode=confirm&mode_sub=proc&type=$line->[0]&chtxt=$line->[1]&title=$line->[3]};
\r
1463 $href = qq {<a href="$url">予約</a>};
\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
1479 $HTML .= qq {</table>\n};
\r
1482 ################ mode=jbk ################
\r
1484 if ( $mode eq 'jbk' ) {
\r
1485 $HTML =~ s/%HTML_TITLE_OPT%/ - JBK/;
\r
1486 $HTML .= qq {<div>\n};
\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
1493 "INSERT INTO in_auto_jbk_key ( keyword )
\r
1494 VALUES ( '$keyword' )"
\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
1504 "DELETE FROM in_auto_jbk_key WHERE id = '$id'"
\r
1507 elsif ( $mode_sub eq 'on' ) {
\r
1508 my $id = $params{ 'id' };
\r
1509 $HTML .= "キーワード「$keyword」を自動録画対象にしました。<br>\n";
\r
1511 "UPDATE in_auto_jbk_key SET auto = 1 WHERE id = '$id'"
\r
1514 elsif ( $mode_sub eq 'off' ) {
\r
1515 my $id = $params{ 'id' };
\r
1516 $HTML .= "キーワード「$keyword」を自動録画対象から外しました。<br>\n";
\r
1518 "UPDATE in_auto_jbk_key SET auto = 0 WHERE id = '$id'"
\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
1531 my $ary_ref = $dbh->selectall_arrayref(
\r
1532 "SELECT id, keyword, auto, opt
\r
1533 FROM in_auto_jbk_key
\r
1536 foreach my $line ( @{ $ary_ref } ) {
\r
1537 my $delurl = "rectool.pl?mode=jbk&mode_sub=del&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&mode_sub=$oppo&id=$line->[0]";
\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
1553 $HTML .= qq {</table>\n};
\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
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
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
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&mode_sub=reserve&chtxt=$line->{chtxt}&start=$line->{btime}&stop=$line->{etime}";
\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
1596 $HTML .= qq {</table>\n};
\r
1600 ################ mode=recognize ################
\r
1602 if ( $mode eq 'recognize' ) {
\r
1603 $HTML =~ s/%HTML_TITLE_OPT%/ - Recognizer/;
\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
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
1623 my $ch_list = join '|', grep /.+/, values %chtxt_0_chname;
\r
1624 my %ch_reverse = reverse %chtxt_0_chname;
\r
1627 my ( $year, $month, $day );
\r
1628 my ( $bhour, $bminute, $ehour, $eminute );
\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
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
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
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&mode_sub=reserve&chtxt=$chtxt&start=$start&stop=$stop&title=$title";
\r
1662 $HTML .= qq {認識結果:$year-$month-$day $bhour:$bminute -> $ehour:$eminute 残り:$_<a href="$url">リンク</a> <br>\n};
\r
1668 ################ mode=expert ################
\r
1670 if ( $mode eq 'expert' ) {
\r
1671 require List::Compare;
\r
1675 $HTML =~ s/%HTML_TITLE_OPT%/ - Expert/;
\r
1676 $HTML .= qq {<div>\n};
\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
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
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
1707 $HTML .= qq {<hr>\n番組表のカテゴリ一覧と内蔵のカテゴリ一覧の合致を確認中...\n};
\r
1708 $ary_ref = $dbh->selectcol_arrayref(
\r
1709 "SELECT DISTINCT category FROM epg_timeline"
\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
1717 $HTML .= qq {一致しました<br>\n};
\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
1733 $HTML .= qq {<hr>\nRec10 バージョン:$rec10_version\nrectool バージョン:$rectool_version\n<br>\n};
\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
1743 my @program_old = ( '', $ary_ref->[0]->[0] );
\r
1744 my $program_old = \@program_old;
\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
1755 $program_old = $program_new;
\r
1757 $HTML .= qq {<pre>\n$line->[0]\n$error</pre>\n} if ( $error );
\r
1761 $ary_ref = $dbh->selectall_arrayref(
\r
1762 "SELECT chname, chtxt, bctype, ch, csch, updatetime, status, visible
\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
1782 $HTML .= qq {</table>\n};
\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
1794 foreach my $line ( @{$ary_ref} ) {
\r
1795 $HTML .= qq {<option value="$line->[1]">$line->[0]</option>\n};
\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
1805 $ary_ref = $dbh->selectall_arrayref(
\r
1806 "SELECT id, type, chtxt, title, btime, etime, opt, deltaday, deltatime
\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
1828 $HTML .= qq {</table>\n};
\r
1831 ################ mode=log ################
\r
1833 if ( $mode eq 'log' ) {
\r
1834 $HTML =~ s/%HTML_TITLE_OPT%/ - Log/;
\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
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
1859 $HTML .= qq {</table>\n};
\r
1862 ################ mode=help ################
\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
1871 ################ mode=test ################
\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
1878 require Data::Dumper;
\r
1879 $tmp = Perl6::Slurp::slurp( 'config.ini' );
\r
1880 $tmp =~ s/\n/<br>\n/gs;
\r
1883 # $HTML .= Dumper( $ary_ref );
\r
1886 ################ mode nasi ################
\r
1890 $HTML =~ s/%HTML_TITLE_OPT%/ - Top/;
\r
1891 $HTML .= qq {Welcome to Rec10!<br>\n};
\r
1897 #<div style="float: right">
\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
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
1916 utf8::encode( $HTML );
\r
1917 print $HTTP_HEADER;
\r
1922 $hires = Time::HiRes::time() - $hires;
\r
1923 $last_modified = localtime((stat 'rectool.pl')[9]);
\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
1946 $chname = $params{ 'chname' };
\r
1947 $chtxt = $params{ 'chtxt' };
\r
1948 $key = $params{ 'key' };
\r
1949 utf8::decode( $key );
\r
1951 $chtxt = $dbh->selectrow_array("SELECT chtxt FROM epg_ch WHERE chname = '$chname' ");
\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
1960 &draw_form_channel();
\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
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
1972 if ( $date eq $date_sel ) {
\r
1973 $HTML .= qq {<option value="$date" selected>$date_prt</option>\n};
\r
1976 $HTML .= qq {<option value="$date">$date_prt</option>\n};
\r
1979 $HTML .= qq {</select>\n};
\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
1989 $HTML .= qq {<option value="$category">$category{$category}->{name}</option>\n};
\r
1992 $HTML .= qq {</select>\n};
\r
1995 $HTML .= qq {<input name="key" type="text" value="$key" style="width:200px" accesskey="s">\n};
\r
1998 $HTML .= qq {<input type="submit" value="更新" accesskey="r">\n</div>\n</form>\n};
\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
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
2011 $HTML .= qq {<option value="$key">$value</option>\n};
\r
2014 $HTML .= qq {</select>\n};
\r
2017 sub draw_form_opt {
\r
2018 my $shift = shift;
\r
2019 my ( %selected, %checked );
\r
2021 if ( $chtxt =~ /BS_103/ ) {
\r
2022 $selected{F} = 'selected';
\r
2024 elsif ( $chtxt =~ /CS_239|CS_240|CS_335/ ) {
\r
2025 $selected{H} = 'selected';
\r
2027 elsif ( $chtxt =~ /BS_101|BS_102/ || $bctype =~ /cs/ ) {
\r
2028 $selected{W} = 'selected';
\r
2030 elsif ( $bctype =~ /bs|te/ ) {
\r
2031 $selected{H} = 'selected';
\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
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
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
2049 $checked{d} = $title =~ /\Q[二]\E|[二]|\Q(二)\E|(二)/ ? 'checked' : '';
\r
2050 $checked{5} = $title =~ /5\.1|5.1/ ? 'checked' : '';
\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
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
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
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
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
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
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
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
2117 $chtxt = $dbh->selectrow_array("SELECT chtxt FROM epg_ch WHERE chname = '$chname'");
\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
2124 elsif ( $chtxt ) {
\r
2125 $chname = $dbh->selectrow_array("SELECT chname FROM epg_ch WHERE chtxt = '$chtxt'")
\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
2132 $bctype = $dbh->selectrow_array("SELECT bctype FROM epg_ch WHERE chtxt = '$chtxt'");
\r
2136 ( $chtxt, $title, $begin, $end ) = $dbh->selectrow_array(
\r
2137 "SELECT chtxt, title, btime, etime FROM auto_timeline_bayes WHERE id = '$bayesid' "
\r
2139 ( $chname, $bctype ) = $dbh->selectrow_array(
\r
2140 "SELECT chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
\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
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
2153 ( $chname, $bctype ) = $dbh->selectrow_array(
\r
2154 "SELECT chname, bctype FROM epg_ch WHERE chtxt = '$chtxt' "
\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
2162 if ( $bctype =~ /bs|cs/ ) {
\r
2163 $bctype_sql = '_s%';
\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
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
2176 if ( $params{ 'title' } ) {
\r
2177 $title = $params{ 'title' };
\r
2178 utf8::decode( $title );
\r
2180 $HTML .= qq {<!-- chtxt=$chtxt chtxt_0=$chtxt_0 chtxt_sql=$chtxt_sql bctype=$bctype -->\n};
\r
2185 my $is_same = $dbh->selectrow_array(
\r
2186 "SELECT COUNT(*) FROM timeline WHERE chtxt = '$chtxt' AND btime = '$begin' AND etime = '$end'"
\r
2188 my @overlap = &get_overlap();
\r
2191 $HTML .= "同一の番組が既に存在します。<br>\n";
\r
2194 elsif ( $overlap[0] >= 2 ) {
\r
2195 $HTML .= "時間が被る番組が既に2個存在します。<br>\n";
\r
2196 $HTML .= $overlap[1];
\r
2206 require List::Util;
\r
2208 my $ary_ref = $dbh->selectall_arrayref(
\r
2209 "SELECT btime, etime, title
\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
2219 my $overlap = $max = 0;
\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
2226 foreach my $key ( sort keys %overlap ) {
\r
2227 $overlap += $overlap{$key};
\r
2228 $max = List::Util::max( $max, $overlap );
\r
2230 if ( wantarray ) {
\r
2231 return ( $max, $str );
\r
2238 sub get_file_list_wrapper {
\r
2239 local $base_dir = shift;
\r
2240 local $ptr = shift;
\r
2242 &get_file_list( $base_dir );
\r
2245 sub get_file_list{
\r
2248 opendir ( DIR, $dir );
\r
2249 my @list = sort readdir( DIR );
\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
2258 $abs = "$dir/$file";
\r
2259 utf8::decode( $abs );
\r
2260 ( $rel ) = $abs =~ /^$base_dir\/(.*)$/;
\r
2261 $ptr->( $rel, $abs );
\r
2269 return $str =~ /.{4}-.{2}-.{2} .{2}:.{2}:.{2}/ ? 0 : 1;
\r
2272 sub str2datetime {
\r
2276 if ( strisjoined( $str ) ) {
\r
2277 @time = $str =~ /(.{4})(.{2})(.{2})(.{2})(.{2})(.{2})/;
\r
2280 @time = $str =~ /(.{4})-(.{2})-(.{2}) (.{2}):(.{2}):(.{2})/;
\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
2291 our %day_name_cache;
\r
2293 if ( !$day_name_cache{$str} ) {
\r
2294 $day_name_cache{$str} = str2datetime( $str )->day_name;
\r
2296 return $day_name_cache{$str};
\r
2299 sub str2readable {
\r
2300 my $begin = shift;
\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
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
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
2321 return ( $str_begin, $str_end, $str_diff );
\r
2324 sub sqlgetsuggested {
\r
2326 require Text::Ngram;
\r
2328 my ( $btime, $etime ) = @_;
\r
2329 $deltatime = 3 if ( !$deltatime );
\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
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
2343 #die Dumper $ary_ref;
\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
2350 map $point += $hash_k->{$_}, keys %{$hash_r};
\r
2351 push @{$hash{$point}}, $program if ( $point );
\r