clivescan

   1 #!/usr/bin/env perl
   2 # -*- coding: ascii -*-
   3 ###########################################################################
   4 # clivescan, the video link scanning utility for clive
   5 #
   6 # Copyright (c) 2008-2009 Toni Gundogdu <legatvs@gmail.com>
   7 #
   8 # Permission to use, copy, modify, and distribute this software for any
   9 # purpose with or without fee is hereby granted, provided that the above
  10 # copyright notice and this permission notice appear in all copies.
  11 #
  12 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  13 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  14 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  15 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  16 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  17 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  18 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  19 ###########################################################################
  20
  21 use warnings;
  22 use strict;
  23
  24 use constant VERSION => "2.1.7";
  25
  26 binmode( STDOUT, ":utf8" );
  27 use Getopt::Long qw(:config bundling);
  28 use WWW::Curl::Easy 4.05;
  29 use File::Find qw(find);
  30 use Config::Tiny;
  31 use File::Spec;
  32 use Encode;
  33
  34 # Non-essentials
  35 my %opted_mods = ( Clipboard => 1, FontDialog => 1 );
  36 eval "use Clipboard";
  37 $opted_mods{Clipboard} = 0 if $@;
  38
  39 my $CONFIGDIR = $ENV{CLIVESCAN_HOME}
  40   || File::Spec->catfile( $ENV{HOME}, ".config/clive-utils" );
  41 my $CONFIGFILE = File::Spec->catfile( $CONFIGDIR, "config" );
  42 my $PREFSFILE  = File::Spec->catfile( $CONFIGDIR, "scan.prefs" );
  43 my $RECALLFILE = File::Spec->catfile( $CONFIGDIR, "scan.recall" );
  44 my $SELECTFILE = File::Spec->catfile( $CONFIGDIR, "scan.sel" );
  45
  46 my %opts;           # options
  47 my @queue;          # current URL queue
  48 my %found_queue;    # results of the scanned video page links
  49 my $curl;           # curl handle (reused through lifespan)
  50 my $mw;             # main window handle (GUI)
  51 my $pwmain;         # handle to the main paned window
  52 my $pwtop;          # handle to the top paned window
  53 my $pwbottom;       # handle to the bottom paned window
  54 my $lbtlink;        # handle to the listbox tree of found links
  55 my $lbtqueue;       # handle to the listbox tree of queued links
  56
  57 # Parse config
  58 my $conf  = Config::Tiny->read($CONFIGFILE);
  59 my $prefs = Config::Tiny->read($PREFSFILE);
  60 %opts = (
  61     clive    => $conf->{clive}->{path},
  62     opts     => $conf->{clive}->{opts},
  63     agent    => $conf->{http}->{agent},
  64     proxy    => $conf->{http}->{proxy},
  65     geometry => $prefs->{gui}->{geometry},
  66     pwmain   => $prefs->{gui}->{pwmain},
  67     pwtop    => $prefs->{gui}->{pwtop},
  68     pwbottom => $prefs->{gui}->{pwbottom},
  69     mainfont => $prefs->{gui}->{mainfont},
  70 );
  71
  72 $opts{strict} = 1;
  73 $opts{mainfont} = $opts{mainfont} || "{helvetica} -12 bold";
  74
  75 GetOptions(
  76     \%opts,
  77     'debug|d',  'help|h',  'all|a',     'agent|U=s', 'proxy|y=s',
  78     'paste|p',  'quiet|q', 'clive|c=s', 'opts|o=s',
  79     'recall|r', 'selected|s',
  80     'version|v' => \&print_version,
  81
  82     # Workaround since '$longopt|shortopt' is a no-no.
  83     'no-proxy|X'  => sub { $opts{proxy}  = "" },
  84     'no-strict|n' => sub { $opts{strict} = 0 },
  85 ) or exit(1);
  86
  87 if ( $opts{help} ) {
  88     require Pod::Usage;
  89     Pod::Usage::pod2usage( -exitstatus => 0, -verbose => 1 );
  90 }
  91
  92 main();
  93
  94 ## Subroutines: Connection
  95
  96 sub init_curl {
  97     $curl = WWW::Curl::Easy->new;
  98     $curl->setopt( CURLOPT_USERAGENT, $opts{agent} || "Mozilla/5.0" );
  99     $curl->setopt( CURLOPT_PROXY,   $opts{proxy} ) if defined $opts{proxy};
 100     $curl->setopt( CURLOPT_VERBOSE, 1 )            if $opts{debug};
 101     $curl->setopt( CURLOPT_FOLLOWLOCATION, 1 );
 102     $curl->setopt( CURLOPT_AUTOREFERER,    1 );
 103     $curl->setopt( CURLOPT_HEADER,         0 );
 104     $curl->setopt( CURLOPT_NOBODY,         0 );
 105 }
 106
 107 sub fetch_page {
 108     my ( $url, $resp, $rc ) = ( shift, 0, 0 );
 109     open my $fh, ">", \$resp;
 110
 111     $curl->setopt( CURLOPT_URL,       $url );
 112     $curl->setopt( CURLOPT_ENCODING,  "" );
 113     $curl->setopt( CURLOPT_WRITEDATA, $fh );
 114     $rc = $curl->perform;
 115
 116     return ( $rc, $fh, decode_utf8($resp) );
 117 }
 118
 119 ## Subroutines: Queue
 120
 121 sub get_queue {
 122     if ( $opts{recall} and -e $RECALLFILE ) {
 123         if ( open my $fh, "<$RECALLFILE" ) {
 124             parse_input($_) while (<$fh>);
 125             close $fh;
 126         }
 127         else {
 128             print STDERR "error: $RECALLFILE: $!\n";
 129         }
 130     }
 131
 132     if ( $opts{paste} ) {
 133         print STDERR "error: Clipboard module not found\n" and exit
 134           unless $opted_mods{Clipboard};
 135         my $data = Clipboard->paste();
 136         if ($data) {
 137             parse_input($_) foreach split /\n/, $data;
 138         }
 139     }
 140
 141     parse_input($_) foreach @ARGV;
 142
 143     if ( scalar(@queue) == 0 && scalar( @ARGV == 0 ) ) {
 144         parse_input($_) while <STDIN>;
 145     }
 146
 147     write_last_file( $RECALLFILE, @queue );
 148 }
 149
 150 sub process_queue {
 151     init_curl();
 152
 153     require HTML::TokeParser;
 154     require Digest::SHA;
 155
 156     foreach (@queue) {
 157         print "fetch $_ ..." unless $opts{quiet};
 158         my ( $rc, $fh, $resp, $errmsg ) = fetch_page($_);
 159         if ( $rc == 0 ) {
 160             $rc = $curl->getinfo(CURLINFO_RESPONSE_CODE);
 161             if ( $rc == 0 or $rc == 200 ) {
 162                 scan_page( $_, \$resp );
 163             }
 164             else {
 165                 $errmsg = $curl->strerror($rc) . " (http/$rc)";
 166             }
 167         }
 168         else {
 169             $errmsg = $curl->strerror($rc) . " (http/$rc)";
 170         }
 171         close $fh;
 172         print STDERR "\nerror: $errmsg\n" if $errmsg;
 173     }
 174 }
 175
 176 sub scan_page {
 177     my ( $scanurl, $pageref ) = @_;
 178     print "done.\n" unless $opts{quiet};
 179     $$pageref =~ tr{\n}//d;
 180
 181     my $p = HTML::TokeParser->new($pageref);
 182     $p->get_tag("title");
 183     my $pagetitle = $p->get_trimmed_text;
 184
 185     # TODO: Clean up.
 186
 187     my %re = (
 188
 189         # in_scanurl: regex used to bind this search pattern to specified
 190         #   domain. Undefined for embedded link searches. See clivescan(1).
 191         # search_for: regex used to grab the video ID
 192         # url_prefix: combined with video ID to construct video page URL
 193
 194         # NOTE: We're not using domains in the search patterns because
 195         # most of the supported hosts refer to their videos using local
 196         # paths, e.g. <a href="/watch?v=...">.
 197         Youtube => {
 198             in_scanurl => qr|youtube(.*).com|i,
 199             search_for => qr|\Q/watch?v=\E(.*?)["< &#%]|i,
 200             url_prefix => "http://youtube.com/watch?v=",
 201         },
 202         YoutubeEmbed => {
 203             in_scanurl => undef,
 204             search_for => qr|.com/v/(.*?)["< &#%]|i,
 205             url_prefix => "http://youtube.com/watch?v=",
 206         },
 207         GVideo => {    # NOTE: Ignores original TLD, uses .com for extraction
 208             in_scanurl => qr|video.google.|i,
 209             search_for => qr|\Q/videoplay?docid=\E(.*?)["< &#%]|i,
 210             url_prefix => "http://video.google.com/videoplay?docid=",
 211         },
 212         GVideoEmbed => {    # NOTE: Ditto.
 213             in_scanurl => undef,
 214             search_for => qr|\Q/googleplayer.swf?docid=\E(.*?)["< &#%]|i,
 215             url_prefix => "http://video.google.com/videoplay?docid=",
 216         },
 217
 218     #        Metacafe => { # NOTE: metacafe.com/watch/$id is enough for redirect
 219     #            in_scanurl => qr|metacafe.com|i,
 220     #            search_for => qr|\Q/watch/\E(.*?)/|i,
 221     #            url_prefix => "http://metacafe.com/watch/",
 222     #        },
 223     #        MetacafeEmbed => {
 224     #            in_scanurl => undef,
 225     #            search_for => qr|\Qmetacafe.com/fplayer/\E(.*?)/|i,
 226     #            url_prefix => "http://metacafe.com/watch/",
 227     #        },
 228         SevenLoad => {    # NOTE: Ditto. Subdomain can be ignored.
 229             in_scanurl => qr|sevenload.com|i,
 230             search_for => qr|\Q/videos/\E(.*?)\-|i,
 231             url_prefix => "http://sevenload.com/videos/",
 232         },
 233         SevenLoadEmbed => {
 234             in_scanurl => undef,
 235             search_for => qr|\Qsevenload.com/pl/\E(.*?)/|i,
 236             url_prefix => "http://sevenload.com/videos/",
 237         },
 238         LastfmYoutube => {    # Lastfm wraps some of the Youtube videos
 239             in_scanurl => qr|last.fm|i,
 240             search_for => qr|\Q/+videos/\E\Q+1-\E(.*?)["< &#%]|i,
 241             url_prefix => "http://youtube.com/watch?v=",
 242         },
 243         Break => {
 244             in_scanurl => qr|break.com|i,
 245             search_for => qr|\Q/index/\E(.*?)["< &#%]|i,
 246             url_prefix => "http://break.com/index/",
 247         },
 248
 249         # TODO: add BreakEmbed, e.g.:
 250         # Page  URL: http://break.com/index/if-all-movies-had-cell-phones.html
 251         # Embed URL: http://embed.break.com/600081
 252         Liveleak => {
 253             in_scanurl => qr|liveleak.com|i,
 254             search_for => qr|\Q/view?i=\E(.*?)["< &#%]|i,
 255             url_prefix => "http://liveleak.com/view?i=",
 256         },
 257         LiveleakEmbed => {
 258             in_scanurl => undef,
 259             url_prefix => "http://liveleak.com/view?i=",
 260             search_for => qr|\Qliveleak.com/e/\E(.*?)["< &#%]|i,
 261         },
 262     );
 263
 264     print "scan " unless $opts{quiet};
 265
 266     sub _scan_progress {
 267         my ( $linksref, $link ) = @_;
 268         push @$linksref, $link;
 269         unless ( $opts{quiet} ) {
 270             if ( scalar(@$linksref) % 5 == 0 ) {
 271                 print scalar(@$linksref);
 272             }
 273             else { print "."; }
 274         }
 275     }
 276
 277     my @links;
 278     while ( my $host = each(%re) ) {
 279         if ( defined $re{$host}{in_scanurl} and $opts{strict} ) {
 280             next unless $scanurl =~ /$re{$host}{in_scanurl}/;
 281         }
 282         _scan_progress( \@links, "$re{$host}{url_prefix}$1" )
 283           while ( $$pageref =~ /$re{$host}{search_for}/g );
 284     }
 285
 286     print "\nremove duplicates ..." unless $opts{quiet};
 287
 288     my %h = map { $_, 1 } @links;    # Weed out duplicates
 289     @links = keys %h;
 290
 291     print " found " . scalar @links . " unique link(s).\n"
 292       unless $opts{quiet};
 293
 294     my %verified_links;
 295     foreach my $link (@links) {
 296         print "fetch $link ..." unless $opts{quiet};
 297         my ( $rc, $fh, $resp, $errmsg ) = fetch_page($link);
 298         if ( $rc == 0 ) {
 299             $rc = $curl->getinfo(CURLINFO_RESPONSE_CODE);
 300             if ( $rc == 0 or $rc == 200 ) {
 301                 print "done.\n" unless $opts{quiet};
 302
 303                 # Grab title
 304                 $p = HTML::TokeParser->new( \$resp );
 305                 $p->get_tag("title");
 306                 my $title = $p->get_trimmed_text;
 307
 308                 # Store, skip if link exists already
 309                 my $sha1 = Digest::SHA::sha1_hex($link);
 310
 311                 $verified_links{$sha1} = { link => $link, title => $title }
 312                   unless defined $verified_links{$sha1};
 313             }
 314             else {
 315                 $errmsg = $curl->strerror($rc) . " (http/$rc)";
 316             }
 317         }
 318         else {
 319             $errmsg = $curl->strerror($rc) . " (http/$rc)";
 320         }
 321         close $fh;
 322         print STDERR "\nerror: $errmsg\n" if $errmsg;
 323     }
 324
 325     if ( $pagetitle and scalar keys %verified_links > 0 ) {
 326         $found_queue{ Digest::SHA::sha1_hex($scanurl) } = {
 327             title  => $pagetitle,
 328             url    => $scanurl,
 329             videos => {%verified_links}
 330         };
 331     }
 332 }
 333
 334 sub grab_all {
 335     my @q;
 336     for my $i ( keys %found_queue ) {
 337         my %videos = %{ $found_queue{$i}{videos} };
 338         for my $j ( keys %videos ) {
 339             push @q, $videos{$j}{link};
 340         }
 341     }
 342     run_clive(@q);
 343 }
 344
 345 ## Subroutines: Helpers
 346
 347 sub main {
 348     $opts{clive} = $opts{clive} || $ENV{CLIVE_PATH};
 349     find_clive() unless $opts{clive};
 350
 351     if ( $opts{selected} and -e $SELECTFILE ) {
 352         if ( open my $fh, "<$SELECTFILE" ) {
 353             parse_input($_) while (<$fh>);
 354             close $fh;
 355             run_clive(@queue);
 356         }
 357         else {
 358             print STDERR "error: $SELECTFILE: $!\n";
 359         }
 360     }
 361     else {
 362         get_queue();
 363
 364         select STDERR;
 365         $| = 1;    # => unbuffered
 366         select STDOUT;
 367         $| = 1;
 368
 369         process_queue();
 370
 371         unless ( $opts{all} ) { init_gui(); }
 372         else                  { grab_all(); }
 373     }
 374 }
 375
 376 sub write_last_file {
 377     my ( $file, @queue ) = @_;
 378     if ( open my $fh, ">$file" ) {
 379         print( $fh "$_\n" ) foreach @queue;
 380         close($fh);
 381     }
 382     else {
 383         print STDERR "error: $file: $!\n";
 384     }
 385 }
 386
 387 sub parse_input {
 388     my $url = shift;
 389
 390     return if $url =~ /^$/;
 391     chomp $url;
 392
 393     $url = "http://$url" if $url !~ m!^http://!i;
 394     push @queue, $url;
 395 }
 396
 397 sub find_clive {
 398     print "locate clive ..." unless $opts{quiet};
 399
 400     require Cwd;
 401     find(
 402         sub {
 403             $opts{clive} = $File::Find::name
 404               if ( $_ eq 'clive' );
 405         },
 406         split /:/,
 407         $ENV{PATH} || Cwd::getcwd
 408     );
 409
 410     if ( $opts{clive} ) { print "$opts{clive}\n" unless $opts{quiet}; }
 411     else {
 412         print STDERR "\nerror: not found, use --clive=path\n";
 413         exit;
 414     }
 415 }
 416
 417 sub run_clive {
 418     my (@q) = @_;
 419
 420     write_last_file( $SELECTFILE, @q );
 421
 422     my $pid = fork;
 423     if ( $pid < 0 ) {
 424         print STDERR "error: fork failed: $!\n";
 425         exit(1);
 426     }
 427     elsif ( $pid != 0 ) {
 428         exec "$opts{clive} $opts{opts} " . join( ' ', @q )
 429           or print STDERR "error: exec failed: $!\n" and exit(1);
 430     }
 431 }
 432
 433 sub print_version {
 434     my $noexit = shift;
 435     my $perl_v = sprintf( "--with-perl=%vd", $^V );
 436     my $str =
 437       sprintf( "clivescan version %s with WWW::Curl version "
 438           . "$WWW::Curl::VERSION  [%s].\n"
 439           . "Copyright (c) 2008-2009 Toni Gundogdu "
 440           . "<legatvs\@gmail.com>.\n\n",
 441         VERSION, $^O );
 442
 443     $str .= "\t$perl_v\n\t";
 444
 445     eval "require Tk::FontDialog";
 446     $opted_mods{FontDialog} = 0 if $@;
 447
 448     my $i = 0;
 449     while ( my ( $key, $value ) = each(%opted_mods) ) {
 450         $str .= sprintf( "--with-$key=%s ", $value ? "yes" : "no" );
 451         $str .= "\n" if ( ++$i % 2 == 0 );
 452     }
 453     $str .=
 454         "\nclivescan is licensed under the ISC license which is "
 455       . "functionally\nequivalent to the 2-clause BSD licence.\n"
 456       . "\tReport bugs to <http://code.google.com/p/clive-utils/issues/>.\n";
 457     return $str if $noexit;
 458     print $str;
 459     exit;
 460 }
 461
 462 # GUI:
 463
 464 sub init_gui {
 465     return if scalar keys %found_queue == 0;
 466
 467     require Tk;
 468     require Tk::Tree;
 469     require Tk::DialogBox;
 470     eval "require Tk::FontDialog";
 471     $opted_mods{FontDialog} = 0 if $@;
 472
 473     $mw = MainWindow->new;
 474     $mw->geometry( $opts{geometry} ) if defined $opts{geometry};
 475     $mw->title('clivescan');
 476     $mw->protocol( 'WM_DELETE_WINDOW', sub { save_prefs(); $mw->destroy } );
 477
 478     # Menubar
 479     my $mb = $mw->Menu;
 480     $mw->configure( -menu => $mb );
 481
 482     # Menu: File
 483     my $file = $mb->cascade( -label => '~File', -tearoff => 0 );
 484     $file->command(
 485         -label   => '~Extract videos in queue...',
 486         -command => \&on_extract
 487     );
 488     $file->separator;
 489     $file->command(
 490         -label   => '~Quit',
 491         -command => sub { save_prefs(); $mw->destroy }
 492     );
 493
 494     # Menu: Edit
 495     if ( $opted_mods{FontDialog} ) {
 496         my $edit = $mb->cascade( -label => '~Edit', -tearoff => 0 );
 497         $edit->command(
 498             -label   => 'Prefere~nces...',
 499             -command => \&on_prefs
 500         );
 501     }
 502
 503     # Menu: Help
 504     my $help = $mb->cascade( -label => '~Help', -tearoff => 0 );
 505     $help->command(
 506         -label   => '~About...',
 507         -command => \&on_about
 508     );
 509
 510     # The GUI has an upper and a lower part
 511     $pwmain = $mw->Panedwindow( -orient => 'v', -opaqueresize => 0 );
 512
 513     # Upper part
 514     $pwtop = $pwmain->Panedwindow( -orient => 'h', -opaqueresize => 0 );
 515
 516     # Upper: Channels
 517     my $lbar = $pwtop->Frame;
 518
 519     $lbtlink = $lbar->Scrolled(
 520         'Tree',
 521         -scrollbars => 'osoe',
 522         -itemtype   => 'text',
 523         -selectmode => 'extended',
 524         -indicator  => 1,
 525         -drawbranch => 1,
 526     )->pack( -side => 'top', -expand => 1, -fill => 'both' );
 527
 528     for my $i ( keys %found_queue ) {
 529         my $scantitle = $found_queue{$i}{title};
 530         $scantitle =~ tr{.}//d;
 531
 532         $lbtlink->add($scantitle);
 533         $lbtlink->itemCreate(
 534             $scantitle, 0,
 535             -text     => $scantitle,
 536             -itemtype => 'text'
 537         );
 538
 539         for my $j ( keys %{ $found_queue{$i}{videos} } ) {
 540             my %video = %{ $found_queue{$i}{videos}{$j} };
 541
 542             my $title = $video{title};
 543             $title =~ tr{.}//d;
 544
 545             my $path;
 546             for ( my $k = 0 ; ; ++$k ) {
 547                 $path = "$scantitle.$title (#$k)";
 548                 last unless $lbtlink->infoExists($path);
 549             }
 550
 551             $lbtlink->add( $path, -data => {%video} );
 552             $lbtlink->itemCreate(
 553                 $path, 0,
 554                 -text     => $title,
 555                 -itemtype => 'text'
 556             );
 557         }
 558     }
 559     $lbtlink->autosetmode;
 560     $lbtlink->close($_) foreach ( $lbtlink->infoChildren('') );
 561
 562     my $rbar = $pwtop->Frame;    # Button toolbar
 563     $rbar->Button(
 564         -text    => 'Grab',
 565         -command => \&on_grab
 566     )->pack( -fill => 'x' );
 567
 568     $rbar->Button(
 569         -text    => 'Grab everything',
 570         -command => \&on_grab_all
 571     )->pack( -fill => 'x' );
 572
 573     $pwtop->add( $lbar, $rbar, -width => $opts{pwtop} || 200 );
 574
 575     # Lower part
 576     $pwbottom = $pwmain->Panedwindow( -orient => 'h', -opaqueresize => 0 );
 577
 578     $lbtqueue = $pwbottom->Scrolled(
 579         'Tree',
 580         -scrollbars => 'osoe',
 581         -itemtype   => 'text',
 582         -selectmode => 'extended',
 583         -indicator  => 1,
 584         -drawbranch => 1,
 585     );
 586
 587     my $bar = $pwbottom->Frame;    # Button toolbar
 588
 589     $bar->Button(
 590         -text    => 'Remove',
 591         -command => \&on_remove
 592     )->pack( -fill => 'x' );
 593
 594     $bar->Button(
 595         -text    => 'Clear',
 596         -command => \&on_clear
 597     )->pack( -fill => 'x' );
 598
 599     $bar->Button(
 600         -text    => 'Extract videos...',
 601         -command => \&on_extract
 602     )->pack( -fill => 'x', -side => 'bottom' );
 603
 604     $pwbottom->add( $lbtqueue, $bar, -width => $opts{pwbottom} || 200 );
 605
 606     # Add upper and lower parts to main paned window
 607     $pwmain->add( $pwtop, $pwbottom, -height => $opts{pwmain} || 200 );
 608
 609     $mw->RefontTree( -font => $opts{mainfont} )
 610       if $opted_mods{FontDialog};
 611
 612     $pwmain->pack( -expand => 1, -fill => 'both' );
 613
 614     Tk->MainLoop;
 615 }
 616
 617 sub save_prefs {
 618     require File::Path;
 619     File::Path::mkpath( [$CONFIGDIR], 0, 0700 );
 620
 621     my $c = Config::Tiny->new;
 622     $c->{gui}->{geometry} = $mw->geometry();
 623     $c->{gui}->{pwmain}   = ( $pwmain->sashCoord(0) )[1] - 7;
 624     $c->{gui}->{pwtop}    = ( $pwtop->sashCoord(0) )[0] - 7;
 625     $c->{gui}->{pwbottom} = ( $pwbottom->sashCoord(0) )[0] - 7;
 626     $c->{gui}->{mainfont} = $opts{mainfont};
 627
 628     $c->write($PREFSFILE);
 629 }
 630
 631 sub on_prefs_ok {
 632     ( $opts{mainfont} ) = @_;
 633     $mw->RefontTree( -font => $opts{mainfont} );
 634     save_prefs();
 635 }
 636
 637 sub queue_item {
 638     my $path = shift;
 639     return if $path !~ /\./;
 640     return if $lbtqueue->infoExists($path);
 641
 642     my %video = %{ $lbtlink->infoData($path) };
 643     my ($link) = split /\./, $path;
 644
 645     unless ( $lbtqueue->infoExists($link) ) {
 646         $lbtqueue->add($link);
 647         $lbtqueue->itemCreate(
 648             $link, 0,
 649             -text     => $link,
 650             -itemtype => 'text'
 651         );
 652     }
 653
 654     $lbtqueue->add( $path, -data => {%video} );
 655     $lbtqueue->itemCreate(
 656         $path, 0,
 657         -text     => $video{title},
 658         -itemtype => 'text'
 659     );
 660 }
 661
 662 sub on_grab {
 663     queue_item($_) foreach ( $lbtlink->infoSelection );
 664     $lbtqueue->autosetmode;
 665 }
 666
 667 sub on_grab_all {
 668     foreach ( $lbtlink->infoChildren("") ) {
 669         my ($parent) = split /\./;
 670         queue_item($_) foreach ( $lbtlink->infoChildren($parent) );
 671     }
 672     $lbtqueue->autosetmode;
 673 }
 674
 675 sub on_remove {
 676     $lbtqueue->deleteEntry($_) foreach ( $lbtqueue->infoSelection );
 677 }
 678
 679 sub on_clear {
 680     $lbtqueue->deleteAll;
 681 }
 682
 683 sub on_about {
 684     my $dlg = $mw->DialogBox( -title => 'About', -buttons => ['OK'] );
 685     my $txt = $dlg->add( 'Text', -height => 9 )->pack;
 686     $txt->insert( 'end', print_version(1) );
 687     $dlg->Show;
 688 }
 689
 690 sub change_font {
 691     my ( $top, $lblv, $lbl ) = @_;
 692     my $font = $top->FontDialog( -initfont => $$lblv )->Show;
 693
 694     if ( defined $font ) {
 695         my $descr = $top->FontDialog->GetDescriptiveFontName($font);
 696         $lbl->configure( -font => $descr );
 697         $$lblv = $descr;
 698     }
 699 }
 700
 701 sub on_prefs {
 702     my $dlg = $mw->DialogBox(
 703         -title   => 'clivescan preferences',
 704         -buttons => [ 'OK', 'Cancel' ]
 705     );
 706
 707     $dlg->add( 'Label', -text => 'Fonts: press to choose' )
 708       ->grid( -sticky => 'w', -pady => 10 );
 709
 710     my ($mainfont) = ( $opts{mainfont} );
 711     my $mainfontl = $dlg->Label( -textvariable => \$mainfont );
 712
 713     $dlg->add(
 714         'Button',
 715         -text    => 'Main font',
 716         -command => sub { change_font( $dlg, \$mainfont, $mainfontl ) }
 717     )->grid( $mainfontl, -sticky => 'w', -padx => '5' );
 718
 719     on_prefs_ok($mainfont) if $dlg->Show eq 'OK';
 720 }
 721
 722 sub on_extract {
 723     my @q;
 724     foreach ( $lbtqueue->infoChildren('') ) {
 725         foreach ( $lbtqueue->infoChildren($_) ) {
 726             my %video = %{ $lbtqueue->infoData($_) };
 727             push @q, $video{link};
 728         }
 729     }
 730     return unless @q;
 731
 732     # Prompt for clive(1) options
 733     my $dlg = $mw->DialogBox(
 734         -title   => 'clive(1) options',
 735         -buttons => [ 'OK', 'Cancel' ]
 736     );
 737
 738     $dlg->add( 'Label', -text => 'Path to clive' )->grid(
 739         my $clivepath = $dlg->Entry( -width => 60 ),
 740         -sticky => 'w',
 741         -padx   => '5'
 742     );
 743
 744     $dlg->add( 'Label', -text => 'Runtime options' )->grid(
 745         my $cliveopts = $dlg->Entry( -width => 60 ),
 746         -sticky => 'w',
 747         -padx   => '5'
 748     );
 749
 750     $clivepath->insert( 'end', $opts{clive} );
 751     $cliveopts->insert( 'end', $opts{opts} );
 752
 753     if ( $dlg->Show() eq 'OK' ) {
 754         $opts{clive} = $clivepath->get;
 755         $opts{opts}  = $cliveopts->get;
 756         $mw->destroy;
 757         run_clive(@q);
 758     }
 759 }
 760
 761 __END__
 762
 763 =head1 SYNOPSIS
 764
 765 clivescan [option]... [URL]...
 766
 767 =head1 OPTIONS
 768
 769  -h, --help             print help and exit
 770  -v, --version          print version and exit
 771  -c, --clive=PATH       path to clive(1) command
 772  -o, --opts=OPTIONS     options passed to clive(1) command
 773  -a, --all              extract all videos without prompting
 774  -s, --selected         re-extract last video selection
 775  -r, --recall           recall last input
 776  -n, --no-strict        work around host specific search pattern issues
 777  -p, --paste            paste input data from clipboard
 778  -U, --agent=STRING     identify as STRING to http server
 779  -y, --proxy=ADDR       use address for http proxy
 780  -X, --no-proxy         do not use http proxy