1#!/usr/local/bin/perl -w 2 3=pod 4 5=head1 NAME 6 7tv_grep - Filter programmes and channels from an XMLTV listings file. 8 9=head1 SYNOPSIS 10 11C<tv_grep [--help] [--output FILE] [--ignore-case|-i] (EXPR | REGEXP) [FILE...]> 12 13=head1 DESCRIPTION 14 15Reads XMLTV listings data and writes out data containing some of the 16programmes and channels from the original. Which programmes and 17channels are left in the output is controlled by the regexp or Boolean 18expression given. 19 20Simple usage is B<tv_grep REGEXP [FILE...]>, where B<REGEXP> is a Perl 5 21regular expression (see L<perlre(1)>). This finds all <programme> 22elements containing text matching the regexp. The channels are left 23unchanged, that is, all the <channel> elements are output. 24 25For more advanced searches, you can specify a Boolean expression 26(which loosely follows the style of find(1)). There are many tests 27for matching programme content against a regular expression, a few for 28matching channels and programmes on those channels, and a few special 29tests. 30 31=head1 OPTIONS 32 33B<--output FILE> write to FILE rather than standard output. 34 35B<--ignore-case>, B<-i> treat all regular expression matches as case insensitive. 36 37=head1 EXPRESSIONS 38 39=head2 PROGRAMME CONTENT TESTS 40 41The tests for programme content match against particular attributes or 42subelements of the <programme> element in the XML data. Each test is 43named the same as the attribute or element it matches. Those which 44take a regexp as an argument match if the programme contains at least 45one attribute or element of the same name whose content matches the 46regexp. Those which do not take a regexp match if the programme 47simply contains one or more attributes or elements of that name. 48 49Some elements may or may not have content - they may just be empty. 50The regular expression '' (the empty string) matches any element, even 51one with empty content, while a nonempty regular expression matches 52only those with content. 53 54For example, B<--desc Racing> matches a programme if the programme has 55at least one <desc> element whose content contains 'Racing'. B<--stop ''> 56(the second argument is the empty string) matches a programme if the 57programme gives a stop time. 58 59There are some elements where only yes/no matching is possible, where 60you cannot give a regexp to query the elementE<39>s content. For 61these the second B<''> argument is mandatory. For example 62B<--previously-shown ''> will match programmes which have that 63element, but a test of B<--previously-shown foo> will give an error 64because querying the content of previously-shown is not implemented. 65The additional empty-string argument is to leave room for future 66expansion. 67 68The content tests are generated from the XMLTV file format. The 69current set of programme content tests is: 70 71@PROGRAMME_CONTENT_TESTS 72 73While every attribute and subelement of <programme> elements is 74included in the above list, for some of them it is normally more 75convenient to use the special tests described below. 76 77=head2 CHANNEL TESTS 78 79There are two tests for channels. These filter both <programme> and 80<channel> elements: if a channel is filtered out then all programmes 81on that channel are too. 82 83B<--channel-name REGEXP> True if the channel has a <name> whose content matches REGEXP. 84 85B<--channel-id CHANNEL_ID> True if the channelE<39>s XMLTV id is exactly equal to CHANNEL_ID. 86 87=head2 TIME TESTS 88 89Normally you donE<39>t want to test time strings with a regular 90expression but rather compare them with some other time. There are 91two tests for this. 92 93B<--on-after DATE> True if the programme will be broadcast at or after 94DATE, or will be part of the way through broadcasting at DATE. (Note: 95a programme is considered to be broadcasting from its start time, up 96to but not including its stop time.) DATE can be given in any sane 97date format; but if you donE<39>t specify the timezone then UTC is 98assumed. To remove all the programmes you have already missed, try 99B<--on-after now>. 100 101B<--on-before DATE> True if the programme will be broadcast wholly 102before DATE, or if it will be part of the way through broadcasting at 103DATE. To remove all the programmes that havenE<39>t yet begun 104broadcasting, try B<--on-before now>. You can use B<--on-before> and 105B<--on-after> together to find all programmes which are broadcasting 106at a certain time. 107 108Another way of thinking about these two tests is that B<--on-after 109now> gives 'all programmes you could possibly still watch, although 110perhaps only catching the end'. B<--on-before now> gives 'all 111programmes you could possibly have seen, even if only the start'. 112 113B<--eval CODE> Evaluate CODE as Perl code, use the return value to 114decide whether to keep the programme. The Perl code will be given 115the programme data in $_ in XMLTV.pm hash format (see L<XMLTV>). The 116code can actually modify the programme passed in, which can be used 117for quick fixups. This option is not intended for normal use, but as 118an escape in case none of the existing tests is what you want. If you 119develop any useful bits of code, please submit them to be included as 120new tests. 121 122=head2 LOGICAL OPERATORS 123 124B<EXPR1 --and EXPR2>, B<EXPR1 -and EXPR2>, B<EXPR1 EXPR2> 125 126B<EXPR1 --or EXPR2>, B<EXPR1 -or EXPR2> 127 128B<--not EXPR>, B<-not EXPR>, B<! EXPR> 129 130Of these, 'not' binds tightest, affecting the following predicate 131only. 'and' is next, and 'or' binds loosest. 132 133=head1 SEE ALSO 134 135L<xmltv(5)>, L<perl(1)>, L<XMLTV(3)>. 136 137=head1 AUTHOR 138 139Ed Avis, ed@membled.com 140 141=head1 BUGS 142 143The --on-after test cannot be totally accurate when the input data did 144not give a stop time for a programme. In this case we assume the stop 145time is equal to the start time. This filters out more programmes than 146if the stop time were given. There will be a warning if this happens 147more than once on any single channel. It could be worthwhile to filter 148the listings data through L<tv_sort(1)> beforehand to add stop times. 149 150Similar remarks apply to --on-before: if the stop time is missing we 151assume it is equal to the start time, and this can mean leaving in a 152programme which, if it had a stop time, would be removed. 153 154The assumption of UTC for dates without timezones could be considered a 155bug. Perhaps the user input should be interpreted according to the 156local timezone. OTOH, if the data has no timezones and neither 157does the user input, then things will work as expected. 158 159The simple usage is the only way to match against all a 160programmeE<39>s content because some things (like <credits>) do not 161have programme content tests defined. It actually works by 162stringifying the whole programme and regexp matching that, which means 163that it could give wrong results for regular expressions containing 164quote characters or some punctuation symbols. This is not 165particularly likely to happen in practice. 166 167Some listings sources generate timeslots containing two or more 168programmes in succession. This is represented in XMLTV with the 169'clumpidx' attribute. If tv_grep selects only some of the programmes 170from a clump, then it will alter the clumpidx of those remaining to 171make it consistent. This is maybe not ideal, perhaps the clumpidx 172should be left unchanged so itE<39>s obvious that something is 173missing, but at least it prevents complaints from other XMLTV tools 174about badly formed clumps. The clumpidx handling does mean that 175tv_grep is not always idempotent. 176 177=cut 178 179use strict; 180use XMLTV::Version '$Id: tv_grep.in,v 1.40 2015/06/08 17:41:14 stefanb2 Exp $ '; 181use XMLTV; 182use XMLTV::Clumps qw(clump_relation fix_clumps); 183use XMLTV::Grep qw(get_matcher); 184use XMLTV::TZ qw(parse_local_date); 185use XMLTV::Date; 186use Data::Dumper; 187use Date::Manip; 188# We will call Date_Init() later on, but to start with, parse 189# command-line arguments in the local timezone. 190# 191 192# Use Log::TraceMessages if installed. 193BEGIN { 194 eval { require Log::TraceMessages }; 195 if ($@) { 196 *t = sub {}; 197 *d = sub { '' }; 198 } 199 else { 200 *t = \&Log::TraceMessages::t; 201 *d = \&Log::TraceMessages::d; 202 Log::TraceMessages::check_argv(); 203 } 204} 205 206sub usage( ;$ ); # too complex for XMLTV::Usage 207sub all_text( $$ ); 208sub abbrev( $$ ); 209sub on_after( $ ); 210sub on_before( $ ); 211sub whole_programme_regexp( $ ); 212 213my $ignore_case = 0; # global flag 214 215my %key_type = %{XMLTV::list_programme_keys()}; 216 217# Tests to apply. We store them as a disjunction of conjunctions, for 218# example (a && b && c) || (d && e) || (f && g). 219# 220# We keep tests separately for programmes and channels: but really the 221# channel tests are just extras and not important. When we add a 222# programme test referring to channels, we add a channel test to go 223# with it so that the list of channels in the output is trimmed. But 224# remember that the tests primarily are there to filter programmes. 225# 226my (@prog_conjs, @curr_prog_conj); 227my (@chan_conjs, @curr_chan_conj); 228 229# Hash mapping regexp -> channel id -> true/undef (see later) 230my %ch_name; 231my @ch_regexps; # regexps to populate %ch_name with 232 233# Prepare an OptionAbbrev object with all the long options we expect 234# to find. 235# 236my $oa = new OptionAbbrev(qw(--ignore-case --help --output 237 --channel-id --channel-name 238 --on-after --on-before --eval 239 --and --or --not)); 240 241# Add the autogenerated options. We add even those which aren't 242# supported just so we can annoy the user with an error message. 243# 244$oa->add(map { "--$_" } keys %key_type); 245 246# Secret debugging option. 247if (@ARGV and $ARGV[0] eq '--echo') { 248 print "arguments enclosed by '':\n"; 249 print "'$_'\n" foreach @ARGV; 250 exit(); 251} 252 253my ($output, $regexp, $ended_options, @filenames); 254my $not = 0; # next arg expected to be a predicate, and negated 255while (@ARGV) { 256 my $arg = shift @ARGV; 257 t 'processing arg: ' . d $arg; 258 259 unless ($ended_options) { 260 if ($arg eq '--') { 261 $ended_options = 1; 262 next; 263 } 264 my @long_opts = $oa->match($arg); 265 my $lo; 266 if (@long_opts >= 2) { 267 die "option $arg ambiguous: could be any of @long_opts\n"; 268 } 269 elsif (@long_opts == 1) { 270 $lo = $long_opts[0]; 271 die unless $lo =~ /^--/; 272 } 273 elsif (@long_opts == 0) { 274 die "unknown long option $arg\n" if $arg =~ /^--/; 275 # Otherwise okay. 276 } 277 else { die } 278 279 if (defined $lo and $lo eq '--help') { 280 usage(1); 281 } 282 283 if (defined $lo and $lo eq '--output') { 284 if (defined $output) { 285 die "option --output can be given only once\n"; 286 } 287 $output = shift @ARGV; 288 if (not defined $output) { 289 die "option --output requires an argument, a filename\n"; 290 } 291 next; 292 } 293 294 if ($arg eq '-i' or (defined $lo and $lo eq '--ignore-case')) { 295 $ignore_case = 1; # no warning if given twice 296 next; 297 } 298 299 # Logical operators --and, --or and --not. --not binds the 300 # most tightly, and affects only the following predicate. 301 # --and is next and binds together predicates in a 302 # conjunction. --or binds loosest and joins together two 303 # conjunctions. 304 # 305 if ($arg eq '-and' or (defined $lo and $lo eq '--and')) { 306 next; 307 } 308 elsif ($arg eq '-o' or $arg eq '-or' 309 or (defined $lo and $lo eq '--or')) { 310 # Finished with this conjunction, start a new one. The 311 # final test is a disjunction of all conjunctions. 312 # 313 # Won't be this easy if we ever implement ( and ). 314 # 315 if (not @curr_prog_conj) { 316 warn "nothing to the left of $arg, should use as EXPR1 $arg EXPR2\n"; 317 usage(); 318 } 319 push @prog_conjs, [ @curr_prog_conj ]; # make a copy 320 @curr_prog_conj = (); 321 322 # And the same for the channel predicates (if any). 323 push @chan_conjs, [ @curr_chan_conj ]; 324 @curr_chan_conj = (); 325 326 next; 327 } 328 elsif ($arg eq '!' or $arg eq '-not' 329 or (defined $lo and $lo eq '--not')) { 330 $not = 1; 331 die "$arg requires a predicate following" if not @ARGV; 332 next; 333 } 334 335 # Called to add a predicate to the current conjunction, taking 336 # account of any preceding 'not'. 337 # 338 my $add_to_prog_conj = sub( $ ) { 339 my $pred = shift; 340 if ($not) { 341 push @curr_prog_conj, sub { not $pred->(@_) }; 342 } 343 else { 344 push @curr_prog_conj, $pred; 345 } 346 }; 347 348 # Similarly for channel filtering. 349 my $add_to_chan_conj = sub( $ ) { 350 my $pred = shift; 351 if ($not) { 352 push @curr_chan_conj, sub { not $pred->(@_) }; 353 } 354 else { 355 push @curr_chan_conj, $pred; 356 } 357 }; 358 359 # See if it's a predicate. 360 if ($arg eq '-e' or (defined $lo and $lo eq '--eval')) { 361 my $code = shift @ARGV; 362 die "-e requires an argument, a snippet of Perl code" 363 if not defined $code; 364 my $pred = eval "sub { $code }"; 365 if ($@) { 366 die "-e $code: $@\n"; 367 } 368 if (not defined $pred) { 369 # Shouldn't happen, I think. 370 die "-e $code failed for some reason"; 371 } 372 $add_to_prog_conj->($pred); 373 $not = 0; 374 next; 375 } 376 377 if (defined $lo and $lo eq '--on-after') { 378 my $date = shift @ARGV; 379 die "--on-after requires an argument, a date and time" 380 if not defined $date; 381 my $pd = parse_local_date($date); 382 die "--on-after $date: invalid date\n" 383 if not defined $pd; 384 t 'parsed date argument: ' . d $pd; 385 $add_to_prog_conj->(sub { on_after($pd) }); 386 $not = 0; 387 next; 388 } 389 390 if (defined $lo and $lo eq '--on-before') { 391 my $date = shift @ARGV; 392 die "--on-before requires an argument, a date and time" 393 if not defined $date; 394 my $pd = parse_local_date($date); 395 die "--on-before $date: invalid date\n" 396 if not defined $pd; 397 t 'parsed date argument: ' . d $pd; 398 $add_to_prog_conj->(sub { on_before($pd) }); 399 $not = 0; 400 next; 401 } 402 403 if (defined $lo and $lo eq '--channel-id') { 404 my $id = shift @ARGV; 405 die "--channel-id requires an argument, an XMLTV internal channel id\n" 406 if not defined $id; 407 # We know every programme has 'channel' and every channel 408 # has 'id'. 409 # 410 $add_to_prog_conj->(sub { $_->{channel} eq $id }); 411 $add_to_chan_conj->(sub { $_->{id} eq $id }); 412 $not = 0; 413 next; 414 } 415 416 if (defined $lo and $lo eq '--channel-name') { 417 my $regexp = shift @ARGV; 418 die "--channel name requires an argument, a Perl regular expression\n" 419 if not defined $regexp; 420 421 # The matchers check against a global hash mapping 422 # channel-name regexps to channel ids to true/undef. We 423 # must remember to create this hash later when we've read 424 # in the channels. 425 # 426 $add_to_prog_conj->(sub { $ch_name{$regexp}->{$_->{channel}} }); 427 $add_to_chan_conj->(sub { $ch_name{$regexp}->{$_->{id}} }); 428 $not = 0; 429 push @ch_regexps, $regexp; 430 next; 431 } 432 433 if (defined $lo) { 434 # Must be one of the autogenerated ones like --title. 435 $lo =~ /^--(.+)/ or die "matched long option $lo, no --"; 436 my $key = $1; 437 t "getting matcher for key $key"; 438 my ($arg_type, $matcher) = @{get_matcher($key, $ignore_case)}; 439 t 'expects extra argument: ' . d $arg_type; 440 my $s; 441 if (not defined $arg_type) { 442 t 'no extra argument wanted'; 443 $s = $matcher; 444 } 445 elsif ($arg_type eq 'regexp') { 446 t 'expects a regexp'; 447 my $arg = shift @ARGV; 448 t 'got arg: ' . d $arg; 449 die "$lo requires an argument, a Perl regular expression\n" 450 if not defined $arg; 451 $s = sub { $matcher->($arg) }; 452 } 453 elsif ($arg_type eq 'empty') { 454 t 'expects empty string'; 455 my $arg = shift @ARGV; 456 t 'got arg: ' . d $arg; 457 die "$lo requires an argument, which currently must be the empty string\n" 458 if $arg ne ''; 459 $s = $matcher; 460 } 461 else { die "bad arg type $arg_type" } 462 $add_to_prog_conj->($s); 463 $not = 0; 464 next; 465 } 466 467 # It wasn't a predicate. Just check that the previous option 468 # wasn't --not, since that requires a predicate to follow. 469 # 470 die "argument '$arg' follows 'not', but isn't a predicate" 471 if $not; 472 } 473 474 # It wasn't an option, see if it's a regexp or filename. 475 if (not $ended_options and $arg =~ /^-/) { 476 die "bad option $arg\n"; 477 } 478 479 # A regular expression is allowed only in the simple case where we 480 # haven't got any of the fancy boolean tests. 481 # 482 if (not defined $regexp 483 and not @prog_conjs and not @curr_prog_conj) { 484 $regexp = $arg; 485 next; 486 } 487 else { 488 push @filenames, $arg; 489 next; 490 } 491} 492push @prog_conjs, \@curr_prog_conj if @curr_prog_conj; 493push @chan_conjs, \@curr_chan_conj if @curr_chan_conj; 494if (not @prog_conjs and not defined $regexp) { 495 warn "neither boolean tests nor regexp given\n"; 496 usage(); 497} 498elsif (not @prog_conjs and defined $regexp) { 499 t "no predicates, but regexp $regexp"; 500 @prog_conjs = ([ sub { whole_programme_regexp($regexp) } ]); 501} 502elsif (@prog_conjs and not defined $regexp) { 503 t 'predicates given, not simple regexp'; 504} 505elsif (@prog_conjs and defined $regexp) { 506 warn "bad argument $regexp\n"; 507 usage(); 508} 509t '\@prog_conjs=' . d \@prog_conjs; 510t '\@chan_conjs=' . d \@chan_conjs; 511# No test for @chan_conjs since there is no test which weeds out 512# channels but does not weed out programmes. (How could there be?) 513# 514 515# Now we have finished parsing dates in arguments, go to UTC mode to 516# parse the files. 517# 518t 'setting Date::Manip timezone to UTC'; 519if (int(Date::Manip::DateManipVersion) >= 6) { 520 Date_Init("SetDate=now,UTC"); 521} else { 522 Date_Init("TZ=UTC"); 523} 524 525@filenames = ('-') if not @filenames; 526my ($encoding, $credits, $ch, $progs) = @{XMLTV::parsefiles(@filenames)}; 527#local $Log::TraceMessages::On = 1; 528 529# Prepare the channel name lookup. 530my %seen_ch_id; 531foreach my $ch_id (keys %$ch) { 532 $seen_ch_id{$ch_id}++ && die "duplicate channel id $ch_id\n"; 533 my $ch = $ch->{$ch_id}; die if not defined $ch; 534 my %seen_re; 535 foreach my $re (@ch_regexps) { 536 next if $seen_re{$re}++; 537 my $matched = 0; 538 if (exists $ch->{'display-name'}) { 539 foreach (map { $_->[0] } @{$ch->{'display-name'}}) { 540 if ($re eq '' 541 or ($ignore_case ? /$re/i : /$re/)) { 542 $matched = 1; 543 last; 544 } 545 } 546 } 547 if ($matched) { 548 $ch_name{$re}->{$ch_id}++ && die; 549 } 550 } 551} 552 553# Filter channels. This has an effect only for the --channel-id and 554# --channel-name predicates; we do not drop channels simply because no 555# programmes remained on them after filtering. 556# 557my %new_ch; 558if (@chan_conjs) { 559 CH: foreach my $ch_id (keys %$ch) { 560 local $_ = $ch->{$ch_id}; 561 CONJ: foreach my $conj (@chan_conjs) { 562 foreach my $test (@$conj) { 563 # Every test in the conjunction must succeed. 564 next CONJ if not $test->(); 565 } 566 # They all succeeded, the channel should be kept. 567 $new_ch{$ch_id} = $_; 568 next CH; 569 } 570 # All the conjunctions failed, won't write. 571 } 572} 573else { 574 # No tests specifically affecting channels, keep the full listing. 575 %new_ch = %$ch; 576} 577 578# Filter programmes. 579my @new_progs; 580my $related = clump_relation($progs); 581PROG: foreach (@$progs) { 582 t 'filtering prog: ' . d $_; 583 CONJ: foreach my $conj (@prog_conjs) { 584 t 'testing against all of conjunction: ' . d $conj; 585 foreach my $test (@$conj) { 586 t 'testing condition: ' . d $test; 587 if ($test->()) { 588 t 'passed, onto next condition in conj (if any)'; 589 } 590 else { 591 t 'failed, so failed this conj'; 592 next CONJ; 593 } 594 } 595 t 'passed all tests in conj, finished with prog'; 596 push @new_progs, $_; 597 next PROG; 598 } 599 t 'failed at least one test in all conjs, not keeping'; 600 fix_clumps($_, [], $related); 601} 602 603# All done, write the new programmes and channels. 604t 'finished grepping, writing'; 605my %w_args = (); 606if (defined $output) { 607 my $fh = new IO::File ">$output"; 608 die "cannot write to $output\n" if not $fh; 609 %w_args = (OUTPUT => $fh); 610} 611XMLTV::write_data([ $encoding, $credits, \%new_ch, \@new_progs ], %w_args); 612exit(); 613 614 615# Parameter: if true, write 'help message' rather than 'usage 616# message', ie write to stdout and exit successfully. 617# 618sub usage( ;$ ) { 619 my $is_help = shift; $is_help = 0 if not defined $is_help; 620 my $msg = <<END 621usage: $0 [--help] [--output FILE] [--ignore-case|-i] (EXPR | REGEXP) [FILE] 622where EXPR may consist of 623(programme content matches) 624END 625 ; 626 627 foreach (sort keys %key_type) { 628 # (Assume ignore-case flag does not affect argument syntax.) 629 my $arg_type = get_matcher($_, 0)->[0]; 630 if (not defined $arg_type) { 631 $msg .= " --$_\n"; 632 } 633 elsif ($arg_type eq 'regexp') { 634 $msg .= " --$_ REGEXP\n"; 635 } 636 elsif ($arg_type eq 'empty') { 637 # Can query on this only for presence. 638 $msg .= " --$_ ''\n"; 639 } 640 else { die } 641 } 642 643 $msg .= <<END 644(channel matches) 645 --channel-name REGEXP 646 --channel-id CHANNEL_ID 647(special tests) 648 --on-after DATE 649 --on-before DATE 650 --eval PERL_CODE 651(logical operators) 652 --not EXPR 653 EXPR1 [--and|-and] EXPR2 654 EXPR1 [--or|-or|-o] EXPR2 655 --and is implicit and may be omitted. 656END 657 ; 658 659 if ($is_help) { 660 print $msg; 661 exit(0); 662 } 663 else { 664 print STDERR $msg; 665 exit(1); 666 } 667} 668 669# all_text() 670# 671# Get all pieces of text for a particular programme attribute. 672# 673# Parameters: 674# programme hashref 675# attribute name, eg 'title', 'desc' 676# 677# Returns: list of text strings for that attribute 678# 679# I wrote Lingua::Preferred::acceptable_lang() especially for this 680# routine but then realized that when grepping you probably don't care 681# about viewing only those strings applicable to the current language. 682# 683sub all_text( $$ ) { 684 my ($p, $key) = @_; 685 return () if not $p->{$key}; 686 return map { $_->[0] } @{$p->{$key}}; 687} 688 689#### 690# Boolean tests. These work on the programme $_ and return true or 691# false. Their behaviour should be affected, if appropriate, by the 692# global $ignore_case. 693# 694my %warned_no_stop; 695sub on_after( $ ) { 696 my $cutoff = shift; 697# local $Log::TraceMessages::On = 1; 698 t "testing on-after $cutoff"; 699 my $stop = $_->{stop}; 700 t 'stop time: ' . d $stop; 701 702 if (not defined $stop) { 703 # We use the start time instead, that will lose some shows 704 # crossing the boundary but is mostly accurate. 705 # 706 my $start = $_->{start}; 707 t 'no stop time, using start time: ' . d $start; 708 my $pd = parse_date($start); 709 t 'parsed to: ' . d $pd; 710 711 my $result = (Date_Cmp($cutoff, $pd) < 0); 712 t 'cutoff before start: ' . $result; 713 if (not $result) { 714 # This programme was dropped, but maybe it wouldn't have 715 # been if it had a stop time. 716 # 717 # We should warn about this: but have an allowance of one 718 # programme per channel without stop time, because you 719 # can reasonably expect that from sorted listings. 720 # 721 unless ($warned_no_stop{$_->{channel}}++) { 722 warn "not all programmes have stop times, " 723 . "cannot accurately filter those on after a certain time\n" 724 . "(maybe filter through tv_sort to add stop times)\n"; 725 } 726 } 727 return $result; 728 } 729 else { 730 my $pd = parse_date($stop); 731 t 'parsed stop time: ' . d $pd; 732 my $r = Date_Cmp($cutoff, $pd) < 0; 733 t 'cutoff before stop: ' . d $r; 734 return $r; 735 } 736} 737 738sub on_before( $ ) { 739 my $cutoff = shift; 740 my $start = $_->{start}; 741 my $pd = parse_date($start); 742 return (Date_Cmp($cutoff, $pd) >= 0); 743} 744 745sub whole_programme_regexp( $ ) { 746 my $re = shift; 747 # Stringify the whole darn thing and match against that. 748 local $_ = Dumper($_); 749# t 'testing stringified whole programme: ' . d $_; 750 return 1 if $re eq ''; 751 return $ignore_case ? /$re/i : /$re/; 752} 753 754 755# Class for long option abbreviation. You tell it all the options 756# you're going to use, and then it will tell you whether a (possibly 757# abbreviated) argument matches an option unambiguously, ambiguously 758# could match several options, or matches none. 759# 760# Having to roll my own Getopt::Long is getting annoying. I wonder 761# how much of this code could be shared? 762# 763package OptionAbbrev; 764 765# Use Log::TraceMessages if installed. 766BEGIN { 767 eval { require Log::TraceMessages }; 768 if ($@) { 769 *t = sub {}; 770 *d = sub { '' }; 771 } 772 else { 773 *t = \&Log::TraceMessages::t; 774 *d = \&Log::TraceMessages::d; 775 } 776} 777 778# Constructor. Give a list of long options and/or add() them later. 779sub new { 780 my $proto = shift; 781 my $class = (ref $proto) || $proto; 782 783 # The representation of an object is a list of long options known 784 # about. 785 # 786 my $self = []; 787 bless $self, $class; 788 $self->add(@_); 789 return $self; 790} 791 792sub add { 793 my $self = shift; 794 foreach (@_) { 795 die 'long options start with --' unless /^--/; 796 foreach my $already (@$self) { 797 die "option $_ already added" if $_ eq $already; 798 } 799 push @$self, $_; 800 } 801 return $self; 802} 803 804# match() returns a list of possible long options matched. So if the 805# list has no elements, no match; one element is the unambiguous 806# match; two or more elements mean ambiguity. 807# 808sub match { 809 my ($self, $arg) = @_; 810 t "matching arg $arg against list: " . d $self; 811 return () unless $arg =~ /^--\w/; 812 t 'begins with --, continue'; 813 foreach (@$self) { 814 t "testing for exact match: '$arg' against '$_'"; 815 return ($_) if $arg eq $_; 816 } 817 t 'no exact match, try initial substring'; 818 my @r; 819 foreach (@$self) { 820 t "testing if $arg is initial substring of $_"; 821 push @r, $_ if index($_, $arg) == 0; 822 } 823 t 'returning list of matches: ' . d \@r; 824 return @r; 825} 826