libvideosite.pm

   1 # library to autodownload flash videos
   2 #
   3 # (c) 2007-2008 by Ralf Ertzinger <ralf@camperquake.de>
   4 # licensed under GNU GPL v2
   5 #
   6 # Based on youtube.pl by Christian Garbs <mitch@cgarbs.de>
   7 # which in turn is
   8 # based on trigger.pl by Wouter Coekaerts <wouter@coekaerts.be>
   9
  10 package libvideosite;
  11 require Exporter;
  12
  13 use vars qw(@ISA @EXPORT_OK);
  14 use File::Spec;
  15 use Module::Load;
  16 use LWP::UserAgent;
  17 use Data::Dumper;
  18 use File::Basename;
  19 use Cwd qw(realpath);
  20 use strict;
  21
  22 @ISA = qw(Exporter);
  23 @EXPORT_OK = qw(init register_api check_for_link);
  24
  25 my @outputstack;
  26 my $outputprefix;
  27 my $debug = 0;
  28 my @grabbers;
  29 my @getters;
  30 my $getter;
  31 my %builtin_config = ();
  32 our $error;
  33
  34 #
  35 # The default config. These values will be set in the config
  36 # if they do not exist already.
  37 #
  38 my $defaultconfig = {
  39     'getter' => 'filegetter',
  40     'mode' => 'download',
  41     'active-connectors' => 'direct',
  42     'defined-connectors' => 'direct',
  43     'connectors' => {
  44         'direct' => {
  45             'name' => 'direct',
  46             '_immutable' => '1',
  47             'schemas' => {},
  48         }
  49     },
  50     'config-version' => '2',
  51 };
  52
  53 #
  54 # This is a list of default values for the remote API. These
  55 # are used if the values are not registered by the library user.
  56 #
  57 my $remote_api = {
  58     io => sub { print @_, "\n" },
  59     config_init => \&_builtin_config_init,
  60     config_get => \&_builtin_config_get,
  61     config_set => \&_builtin_config_set,
  62     config_has => \&_builtin_config_has,
  63     config_save => \&_builtin_config_save,
  64     config_del => \&_builtin_config_del,
  65     color => sub { return '' },
  66     module_path => sub { return dirname(realpath($0)) },
  67     quote => sub { return $_ },
  68     reload => sub {},
  69 };
  70
  71 #
  72 # List of known commands and handlers
  73 #
  74 my $videosite_commands = {
  75     'save' => sub {
  76         _cmd_save();
  77     },
  78
  79     'set' => sub {
  80         _cmd_set(@_);
  81     },
  82
  83     'show' => sub {
  84         _cmd_show(@_);
  85     },
  86
  87     'help' => sub {
  88         _cmd_help(@_);
  89     },
  90
  91     'getter' => sub {
  92         _cmd_getter(@_);
  93     },
  94
  95     'enable' => sub {
  96         _cmd_enable(@_);
  97     },
  98
  99     'disable' => sub {
 100         _cmd_disable(@_);
 101     },
 102
 103     'reload' => sub {
 104         $remote_api->{reload}->();
 105     },
 106
 107     'mode' => sub {
 108         _cmd_mode(@_);
 109     },
 110
 111     'connector' => sub {
 112         _cmd_connector(@_);
 113     },
 114
 115     'debug' => sub {
 116         $debug = 1;
 117         foreach (@grabbers, @getters) {
 118             $_->setdebug(1);
 119         }
 120         _io('Enabled debugging');
 121     },
 122
 123     'nodebug' => sub {
 124         $debug = 0;
 125         foreach (@grabbers, @getters) {
 126             $_->setdebug(0);
 127         }
 128         _io('Disabled debugging');
 129     },
 130 };
 131
 132 #
 133 # Output a string on the client.
 134 # Works like (s)printf in that it takes a format string and a list of
 135 # values to be replaced. Undefined values will be printed as '(undef)'
 136 #
 137 # All parameters (except for the format string itself) will be quoted
 138 # using the client specific quote function
 139 #
 140 sub _io {
 141     my @text = @_;
 142     my $format;
 143
 144     @text = ('') unless(@text);
 145
 146     # This will define the outputprefix once, so we don't have
 147     # do do this every time.
 148     $outputprefix = sprintf("%svideosite: %s",
 149         _colorpair('magenta'),
 150         _colorpair()) unless(defined($outputprefix));
 151     $format = $outputprefix . shift(@text);
 152
 153     #
 154     # The format string is assumed to be appropriately quoted.
 155     # Quote the rest of the text, replacing undefined strings by (undef)
 156     #
 157     @text = map { defined($_)?$remote_api->{quote}->($_):'(undef)' } @text;
 158
 159     $outputstack[0]->(sprintf($format, @text));
 160 }
 161
 162 #
 163 # Recursively walk through a hash-of-hashes, calling the given function
 164 # for each found leaf with the path to the leaf
 165 #
 166 sub _recursive_hash_walk {
 167     my $hash = shift;
 168     my $callback = shift;
 169     my @path = @_;
 170
 171     foreach (keys(%{$hash})) {
 172         if (ref($hash->{$_}) eq 'HASH') {
 173             _recursive_hash_walk($hash->{$_}, $callback, @path, $_);
 174         } else {
 175             $callback->([@path, $_], $hash->{$_});
 176         }
 177     }
 178 }
 179
 180 #
 181 # Return the color code for the given foreground/background color
 182 # pair. Both can be undef, which means "default"
 183 #
 184 sub _colorpair {
 185     my ($fg, $bg) = @_;
 186
 187     $fg = defined($fg)?$fg:'default';
 188     $bg = defined($bg)?$bg:'default';
 189
 190     return $remote_api->{color}->($fg, $bg);
 191 }
 192
 193 #
 194 # Sets the given config item if it is not set already
 195 #
 196 sub _init_config_item {
 197     my $path = shift;
 198     my $value = shift;
 199
 200     unless(_config_has($path)) {
 201         _config_set($path, $value);
 202     }
 203 }
 204
 205 #
 206 # Print a message if debug is enabled
 207 #
 208 sub _debug {
 209     if ($debug) {
 210         _io(@_);
 211     }
 212 }
 213
 214 #
 215 # Load a list of modules matching a pattern from a given directory.
 216 #
 217 sub _ploader {
 218
 219     my $dir = shift;
 220     my $pattern = shift;
 221     my $type = shift;
 222     my @list;
 223     my $p;
 224     my $g;
 225     my @g = ();
 226
 227     opendir(D, $dir) || return ();
 228     @list = grep {/$pattern/ && -f File::Spec->catfile($dir, $_) } readdir(D);
 229     closedir(D);
 230
 231     foreach $p (@list) {
 232         _debug("Trying to load $p:");
 233         $p =~ s/\.pm$//;
 234         eval {
 235             load "videosite::$p";
 236         };
 237         if ($@) {
 238             _io("Failed to load plugin: $@");
 239             next;
 240         }
 241
 242         eval {
 243             $g = "videosite::$p"->new();
 244         };
 245         if ($@) {
 246             _io("Failed to instanciate: $@");
 247             delete($INC{$p});
 248             next;
 249         }
 250
 251         _debug("found $g->{'TYPE'} $g->{'NAME'}");
 252         if ($type eq $g->{'TYPE'}) {
 253             push(@g, $g);
 254             $g->register_api({
 255                 io => \&_io,
 256                 connectors => sub { return _connectorlist('active-connectors') },
 257                 config_get => \&_config_get,
 258                 config_set => \&_config_set,
 259                 config_has => \&_config_has,
 260             });
 261             $g->setdebug($debug);
 262         } else {
 263             _io('%s has wrong type (got %s, expected %s)', $p, $g->{'TYPE'}, $type);
 264             delete($INC{$p});
 265         }
 266     }
 267
 268     _debug("Loaded %d plugins", $#g+1);
 269
 270     return @g;
 271 }
 272
 273 #
 274 # Populate the @grabbers and @getters lists from the given
 275 # directory
 276 #
 277 sub _load_modules($) {
 278
 279     my $path = shift;
 280
 281     foreach (keys(%INC)) {
 282         if ($INC{$_} =~ m|^$path|) {
 283             _debug("Removing %s from \$INC", $_);
 284             delete($INC{$_});
 285         }
 286     }
 287     @grabbers = _ploader($path, '.*Grabber\.pm$', 'grabber');
 288     @getters = _ploader($path, '.*Getter\.pm$', 'getter');
 289 }
 290
 291 #
 292 # Wrapper functions for config management to put in
 293 # debugging
 294 #
 295 sub _config_get {
 296     my $path = shift;
 297     my $value;
 298
 299     $value = $remote_api->{config_get}->($path);
 300     _debug("config: getting %s=%s", join('.', @{$path}), $value);
 301
 302     return $value;
 303 }
 304
 305 sub _config_set {
 306     my $path = shift;
 307     my $value = shift;
 308
 309     _debug("config: setting %s=%s", join('.', @{$path}), $value);
 310     return $remote_api->{config_set}->($path, $value);
 311 }
 312
 313 sub _config_has {
 314     my $path = shift;
 315     my $b;
 316
 317     $b = $remote_api->{config_has}->($path);
 318     _debug("config: testing %s (%s)", join('.', @{$path}), $b?'true':'false');
 319
 320     return $b;
 321 }
 322
 323 sub _config_del {
 324     my $path = shift;
 325
 326     _debug("config: removing %s", join('.', @{$path}));
 327     $remote_api->{config_del}->($path);
 328 }
 329
 330 #
 331 # The _config_list_* are helper functions taking a path to a comma separated
 332 # string. The string is interpreted as a list and the action performed
 333 # on it, storing back the modified version
 334 #
 335
 336 #
 337 # Add an item to the list, checking for duplicates
 338 #
 339 sub _config_list_add {
 340     my $path = shift;
 341     my $item = shift;
 342     my @c;
 343
 344     if (_config_has($path)) {
 345         @c = split(/\s*,\s*/, _config_get($path));
 346     } else {
 347         @c = ();
 348     }
 349
 350     _debug("Adding %s to list %s", $item, join(".", @{$path}));
 351     unless(grep { $_ eq $item } @c) {
 352         push(@c, $item);
 353     };
 354
 355     _config_set($path, join(',', @c));
 356 }
 357
 358 #
 359 # Remove an item from the list
 360 #
 361 sub _config_list_del {
 362     my $path = shift;
 363     my $item = shift;
 364     my @c;
 365
 366     unless(_config_has($path)) {
 367         return;
 368     }
 369
 370     _debug("Removing %s from list %s", $item, join('.', @{$path}));
 371     @c = grep { $item ne $_ } split(/\s*,\s*/, _config_get($path));
 372
 373     _config_set($path, join(',', @c));
 374 }
 375
 376 #
 377 # Return true if the item contains the given list, false otherwise
 378 #
 379 sub _config_list_has {
 380     my $path = shift;
 381     my $item = shift;
 382
 383     unless(_config_has($path)) {
 384         return 0;
 385     }
 386
 387     _debug("Checking for %s in list %s",  $item, join('.', @{$path}));
 388
 389     return grep { $item eq $_ } split(/\s*,\s*/, _config_get($path));
 390 }
 391
 392 #
 393 # Replace a list with the given items
 394 #
 395 sub _config_list_set {
 396     my $path = shift;
 397
 398     _debug("Replacing %s with (%s)", join('.', @{$path}), join(",", @_));
 399
 400     _config_set($path, join(',', @_));
 401 }
 402
 403 #
 404 # Return the list of currently active connectors, in the configured
 405 # order
 406 #
 407 sub _connectorlist {
 408     my $key = shift;
 409     my @c;
 410
 411     foreach(split(/,/, _config_get([$key]))) {
 412         push(@c, _unserialize_connector_hash($_));
 413     }
 414
 415     return @c;
 416 }
 417
 418 #
 419 # Convert a connector hash from it's config structure back to a perl
 420 # hash
 421 #
 422 sub _unserialize_connector_hash {
 423     my $name = shift;
 424     my $connector = {};
 425
 426     if (_config_has(['connectors', $name, 'name'])) {
 427         $connector->{name} = _config_get(['connectors', $name, 'name']);
 428         $connector->{schemas} = {};
 429         foreach ('http', 'https') {
 430             if (_config_has(['connectors', $name, 'schemas', $_])) {
 431                 $connector->{schemas}->{$_} = _config_get(['connectors', $name, 'schemas', $_]);
 432             }
 433         }
 434     }
 435
 436     _debug("Returning connector %s: %s", $name, Dumper($connector));
 437
 438     return $connector;
 439 }
 440
 441 #
 442 # Push a new output function on the IO stack.
 443 #
 444 sub _push_output {
 445     unshift(@outputstack, shift);
 446 }
 447
 448 #
 449 # Pop the topmost output function from the stack, leaving
 450 # at least one function on it.
 451 #
 452 sub _pop_output {
 453     if (scalar(@outputstack) > 0) {
 454         shift(@outputstack);
 455     }
 456 }
 457
 458 #
 459 # Takes a string and replaces commonly used URL shorteners recursively,
 460 # up to 10 levels deep
 461 #
 462 sub _expand_url_shortener {
 463     my $s = shift;
 464     my $os = '';
 465     my @urlshortener = (
 466         'is\.gd/[[:alnum:]]+',
 467         'otf\.me/[[:alnum:]]+',
 468         'hel\.me/[[:alnum:]]+',
 469         '7ax\.de/[[:alnum:]]+',
 470         'ow\.ly/[[:alnum:]]+',
 471         'j\.mp/[[:alnum:]]+',
 472         'bit\.ly/[[:alnum:]]+',
 473         'tinyurl\.com/[[:alnum:]]+',
 474         'pop\.is/[[:alnum:]]+',
 475         'post\.ly/[[:alnum:]]+',
 476         '1\.ly/[[:alnum:]]+',
 477         '2\.ly/[[:alnum:]]+',
 478         't\.co/[[:alnum:]]+',
 479         'shar\.es/[[:alnum:]]+',
 480         'goo\.gl/[[:alnum:]]+',
 481         );
 482     my $ua = LWP::UserAgent->new(agent => 'Mozilla', max_redirect => 0, timeout => 5);
 483     my $i = 10;
 484
 485     OUTER: while (($os ne $s) and ($i > 0)) {
 486         study($s);
 487         $os = $s;
 488         $i--;
 489
 490         foreach my $pattern (@urlshortener) {
 491             my $p = "https?:\/\/" . $pattern;
 492
 493             _debug("Matching %s against %s", $p, $s);
 494             if ($s =~ m|($p)|) {
 495                 my $matched = $1;
 496                 my $res;
 497
 498                 _debug("Found %s", $matched);
 499                 $res = $ua->head($matched);
 500                 if ($res->is_redirect()) {
 501                     my $new = $res->headers()->header("Location");
 502
 503                     _debug("Replacing %s with %s", $matched, $new);
 504                     $s =~ s/$matched/$new/;
 505                     next OUTER;
 506                 } else {
 507                     _debug("Error resolving %s", $matched);
 508                 }
 509             }
 510         }
 511     }
 512
 513     if ($i == 0) {
 514         _debug("Loop terminated by counter");
 515     }
 516
 517     _debug("Final string: %s", $s);
 518
 519     return $s;
 520 }
 521
 522 #
 523 # Save the config to durable storage
 524 #
 525 sub _cmd_save {
 526     if ($remote_api->{config_save}->()) {
 527         _io("Config saved");
 528     } else {
 529         _io(sprintf("%sConfig save failed%s", _colorpair("*red"), _colorpair()));
 530     }
 531 }
 532
 533 #
 534 # Set a configuration element
 535 #
 536 sub _cmd_set {
 537     my $target = shift;
 538     my $key = shift;
 539     my $val = shift;
 540     my $p;
 541
 542     foreach $p (@getters, @grabbers) {
 543         if ($p->{'NAME'} eq $target) {
 544             $p->setval($key, $val);
 545             return;
 546         }
 547     }
 548     _io('No such module');
 549 }
 550
 551
 552 #
 553 # Enable a given module
 554 #
 555 sub _cmd_enable {
 556     my $target = shift;
 557     my $p;
 558
 559     foreach $p (@grabbers) {
 560         if ($p->{'NAME'} eq $target) {
 561             $p->enable();
 562             return;
 563         }
 564     }
 565     _io('No such module');
 566 }
 567
 568 #
 569 # Disable given module
 570 #
 571 sub _cmd_disable {
 572     my $target = shift;
 573     my $p;
 574
 575     foreach $p (@grabbers) {
 576         if ($p->{'NAME'} eq $target) {
 577             $p->disable();
 578             return;
 579         }
 580     }
 581     _io('No such module');
 582 }
 583
 584 #
 585 # Show settings for modules
 586 #
 587 sub _cmd_show {
 588     my $target = shift;
 589     my $p;
 590     my $e;
 591
 592     if (defined($target)) {
 593         foreach $p (@getters, @grabbers) {
 594             if ($p->{'NAME'} eq $target) {
 595                 _io($p->getconfstr());
 596                 return;
 597             }
 598         }
 599         _io('No such module');
 600     } else {
 601         _io('Loaded grabbers (* denotes enabled modules):');
 602         foreach $p (@grabbers) {
 603             $e = $p->_getval('enabled');
 604             _io(' %s%s', $p->{'NAME'}, $e?'*':'');
 605         };
 606
 607         _io('Loaded getters:');
 608         foreach $p (@getters) {
 609             _io(' %s', $p->{'NAME'});
 610         };
 611     }
 612 }
 613
 614 #
 615 # Show help for the commands
 616 #
 617 sub _cmd_help {
 618     my $target = shift;
 619     my $p;
 620
 621     if (defined($target)) {
 622         foreach $p (@getters, @grabbers) {
 623             if ($p->{'NAME'} eq $target) {
 624                 _io($p->gethelpstr());
 625                 return;
 626             }
 627         }
 628         _io('No such module');
 629     } else {
 630         _io(<<'EOT');
 631 Supported commands:
 632  save: save the current configuration
 633  help [modulename]: display this help, or module specific help
 634  show [modulename]: show loaded modules, or the current parameters of a module
 635  set modulename parameter value: set a module parameter to a new value
 636  getter [modulename]: display or set the getter to use
 637  enable [modulename]: enable the usage of this module (grabbers only)
 638  disable [modulename]: disable the usage of this module (grabbers only)
 639  reload: reload all modules (this is somewhat experimental)
 640  mode [modename]: display or set the operation mode (download/display)
 641  connector [subcommand]: manage connectors (proxies)
 642  debug: enable debugging messages
 643  nodebug: disable debugging messages
 644 EOT
 645     }
 646 }
 647
 648 #
 649 # Set the getter to use
 650 #
 651 sub _cmd_getter {
 652     my $target = shift;
 653     my $p;
 654
 655     if (defined($target)) {
 656         foreach $p (@getters) {
 657             if ($p->{'NAME'} eq $target) {
 658                 $getter = $p;
 659                 _config_set(['getter'], $target);
 660                 _io("Getter changed to %s", $target);
 661                 return;
 662             }
 663         }
 664         _io('No such getter');
 665     } else {
 666         _io('Current getter: %s', _config_get(['getter']));
 667     }
 668 }
 669
 670 #
 671 # Show/set the working mode
 672 #
 673 sub _cmd_mode {
 674     my $mode = shift;
 675
 676     if (defined($mode)) {
 677         $mode = lc($mode);
 678         if (('download' eq $mode) or ('display' eq $mode)) {
 679             _config_set(['mode'], $mode);
 680             _io('Now using %s mode', $mode);
 681         } else {
 682             _io('Invalid mode: %s', $mode);
 683         }
 684     } else {
 685         _io('Current mode: %s', _config_get(['mode']));
 686     }
 687 }
 688
 689
 690 #
 691 # Manage the connectors
 692 #
 693 sub _cmd_connector {
 694     my $subcmd = shift;
 695     my $c;
 696
 697     unless(defined($subcmd)) {
 698         $subcmd = "help";
 699     }
 700
 701     $subcmd = lc($subcmd);
 702
 703     if ($subcmd eq 'list') {
 704         _io("Defined connectors");
 705         foreach $c (_connectorlist('defined-connectors')) {
 706             _io($c->{name});
 707             my $schemas = $c->{schemas};
 708             if (scalar(keys(%{$schemas})) == 0) {
 709                 _io(" No schemas defined");
 710             } else {
 711                 foreach (keys(%{$schemas})) {
 712                     _io(' %s: %s', $_, $schemas->{$_});
 713                 }
 714             }
 715         }
 716
 717         _io();
 718         _io("Selected connectors: %s", _config_get(['active-connectors']));
 719     } elsif ($subcmd eq 'add') {
 720         my ($name) = @_;
 721
 722         unless(defined($name)) {
 723             _io("No name given");
 724             return;
 725         }
 726
 727         $name = lc($name);
 728
 729         unless($name =~ m|^[a-z]+$|) {
 730             _io("%s is not a valid connector name (only letters are allowed)", $name);
 731             return;
 732         }
 733
 734         if (_config_list_has(['defined-connectors'], $name)) {
 735             _io("Connector already exists");
 736             return;
 737         }
 738
 739         _config_set(['connectors', $name, 'name'], $name);
 740         _config_list_add(['defined-connectors'], $name);
 741     } elsif ($subcmd eq 'del') {
 742         my ($name) = @_;
 743         my @dcon;
 744
 745         unless(defined($name)) {
 746             _io("No name given");
 747             return;
 748         }
 749
 750         unless (_config_list_has(['defined-connectors'], $name)) {
 751             _io("Connector does not exist");
 752             return;
 753         }
 754
 755         if (_config_has(['connectors', $name, '_immutable'])) {
 756             _io("Connector cannot be removed");
 757             return;
 758         }
 759
 760         # Remove from list of active connectors
 761         _config_list_del(['defined-connectors'], $name);
 762         _config_list_del(['active-connectors'], $name);
 763
 764         _config_del(['connectors', $name, 'name']);
 765         _config_del(['connectors', $name, '_immutable']);
 766         _config_del(['connectors', $name, 'schemas', 'http']);
 767         _config_del(['connectors', $name, 'schemas', 'https']);
 768
 769         @dcon = split(/,/, _config_get(['active-connectors']));
 770
 771         if (scalar(@dcon) == 0) {
 772             _io("List of selected connectors is empty, resetting to direct");
 773             _config_list_add(['active-connectors', 'direct']);
 774         }
 775     } elsif ($subcmd eq 'addschema') {
 776         my ($conn, $schema, $proxy) = @_;
 777
 778         unless(defined($conn)) {
 779             _io("No connector name given");
 780             return;
 781         }
 782
 783         unless(defined($schema)) {
 784             _io("No schema given");
 785             return;
 786         }
 787
 788         unless(defined($proxy)) {
 789             _io("No proxy given");
 790             return;
 791         }
 792
 793         $conn = lc($conn);
 794         unless(_config_list_has(['defined-connectors'], $conn)) {
 795             _io("Connector does not exist");
 796             return;
 797         }
 798
 799         if (_config_has(['connectors', $conn, '_immutable'])) {
 800             _io("Connector cannot be modified");
 801             return;
 802         }
 803
 804         $schema = lc($schema);
 805         _config_set(['connectors', $conn, 'schemas', $schema], $proxy);
 806     } elsif ($subcmd eq 'delschema') {
 807         my ($conn, $schema) = @_;
 808
 809         unless(defined($conn)) {
 810             _io("No connector name given");
 811             return;
 812         }
 813
 814         unless(defined($schema)) {
 815             _io("No schema given");
 816             return;
 817         }
 818
 819         $conn = lc($conn);
 820         unless(_config_list_has(['defined-connectors'], $conn)) {
 821             _io("Connector does not exist");
 822             return;
 823         }
 824
 825         $schema = lc($schema);
 826         _config_del(['connectors', $conn, 'schemas', $schema]);
 827     } elsif ($subcmd eq 'select') {
 828         my @connlist = map { lc } @_;
 829
 830         if (scalar(@connlist) == 0) {
 831             _io("No connectors given");
 832             return;
 833         }
 834
 835         foreach (@connlist) {
 836             unless(_config_list_has(['defined-connectors'], $_)) {
 837                 _io("Connector %s does not exist", $_);
 838                 return;
 839             }
 840         }
 841
 842         _config_list_set(['active-connectors'], @connlist);
 843     } else {
 844         _io("connector [list|add|del|addschema|delschema|help] <options>");
 845         _io(" help: Show this help");
 846         _io(" list: List the defined connectors");
 847         _io(" add <name>: Add a connector with name <name>");
 848         _io(" del <name>: Delete the connector with name <name>");
 849         _io(" addschema <name> <schema> <proxy>: Add proxy to connector for the given schema");
 850         _io(" delschema <name> <schema>: Remove the schema from the connector");
 851         _io(" select <name> [<name>...]: Select the connectors to use");
 852     }
 853 }
 854
 855 #
 856 # Return the list of loaded grabbers.
 857 # This is used by the test programs, and is not meant to be
 858 # used in general.
 859 #
 860 sub _grabbers {
 861     return @grabbers;
 862 }
 863
 864 #
 865 # ==============================================
 866 # Builtin config handling functions
 867 # These are used if the library used does not
 868 # register it's own config_* handlers
 869 # ==============================================
 870 #
 871 sub _builtin_config_init {
 872 }
 873
 874 sub _builtin_config_get {
 875     return $builtin_config{join(".", @{$_[0]})};
 876 }
 877
 878 sub _builtin_config_set {
 879     $builtin_config{join(".", @{$_[0]})} = $_[1];
 880 }
 881
 882 sub _builtin_config_has {
 883     return exists($builtin_config{join(".", @{$_[0]})});
 884 }
 885
 886 sub _builtin_config_save {
 887 }
 888
 889 sub _builtin_config_del {
 890     delete($builtin_config{join(".", @{$_[0]})});
 891 }
 892
 893 #
 894 # ==============================================
 895 # From this point on publicly callable functions
 896 # ==============================================
 897 #
 898
 899
 900 #
 901 # Initialization function for the library
 902 # Actually not the first thing to be called, it expects an API
 903 # has (register_api) to be registered first
 904 #
 905 sub init {
 906     unless($remote_api) {
 907         $error = "No API set";
 908         return 0;
 909     }
 910
 911     # Initialize configuration data
 912     $remote_api->{config_init}->();
 913
 914     # Check/create default values, if they do not exist
 915     _recursive_hash_walk($defaultconfig, \&_init_config_item);
 916
 917     # Load modules
 918     _load_modules(File::Spec->catfile($remote_api->{module_path}->(), 'videosite'));
 919
 920     unless (@grabbers && @getters) {
 921         _io('No grabbers or no getters found, can not proceed.');
 922         return 0;
 923     }
 924
 925     # Set the getter
 926     $getter = $getters[0];
 927     foreach my $p (@getters) {
 928         if (_config_get(['getter']) eq $p->{'NAME'}) {
 929             $getter = $p;
 930         }
 931     }
 932     _debug('Selected %s as getter', $getter->{'NAME'});
 933     _config_set(['getter'], $getter->{'NAME'});
 934
 935     # Done.
 936     _io('initialized successfully');
 937     return 1;
 938 }
 939
 940 #
 941 # Register a remote API. This API contains a basic output function (used
 942 # when no window specific function is available), some config functions
 943 # and a color code function.
 944 #
 945 sub register_api {
 946     my $a = shift;
 947     my @config_functions = qw(config_init config_set config_get config_has config_save config_del);
 948     my $c;
 949     my @missing;
 950
 951     unless(defined($a)) {
 952         die("No API given");
 953     }
 954
 955     #
 956     # The config_* handlers are special in that they either all have
 957     # provided by the user, or none. In the latter case builtin
 958     # handlers will be used, but the config will not persist.
 959     #
 960     $c = 0;
 961     foreach (@config_functions) {
 962         if (exists($a->{$_})) {
 963             $c++;
 964         } else {
 965             push(@missing, $_);
 966         }
 967     }
 968
 969     unless (($c == 0) or ($c == scalar(@config_functions))) {
 970         $error = sprintf("Missing config function: %s", $missing[0]);
 971         return 0;
 972     }
 973
 974     foreach (keys(%{$a})) {
 975         if (ref($a->{$_}) ne 'CODE') {
 976             $error = sprintf("API handler %s is not a subroutine reference", $_);
 977         }
 978         $remote_api->{$_} = $a->{$_};
 979     }
 980
 981     if (exists($a->{_debug})) {
 982         $debug = $a->{_debug}->();
 983     }
 984
 985     @outputstack = ($remote_api->{'io'});
 986
 987     return 1;
 988 }
 989
 990 #
 991 # Check a message for useable links
 992 #
 993 sub check_for_link {
 994     my $event = shift;
 995     my $message = $event->{message};
 996     my $g;
 997     my $m;
 998     my $p;
 999     my $skip;
1000     my $mode = _config_get(['mode']);
1001
1002
1003     #
1004     # If /nosave is present in the message switch to display mode, regardless
1005     # of config setting
1006     #
1007     if ($message =~ m,(?:\s|^)/nosave(?:\s|$),) {
1008         $mode = 'display';
1009     }
1010
1011     _push_output($event->{ewpf});
1012     $message = _expand_url_shortener($message);
1013
1014     study($message);
1015
1016     # Offer the message to all Grabbers in turn
1017     GRABBER: foreach $g (@grabbers) {
1018         ($m, $p) = $g->get($message);
1019         while (defined($m)) {
1020             _debug('Metadata: %s', Dumper($m));
1021             $skip = 0;
1022             if (exists($remote_api->{link_callback})) {
1023                 $skip = $remote_api->{link_callback}->($m);
1024             }
1025             unless($skip) {
1026                 if ('download' eq $mode) {
1027                     _io(
1028                         sprintf('%s>>> %sSaving %s%%s%s %s%%s',
1029                             _colorpair('*red'),
1030                             _colorpair(),
1031                             _colorpair('*yellow'),
1032                             _colorpair(),
1033                             _colorpair('*green'),
1034                         ),
1035                         $m->{'SOURCE'},
1036                         $m->{'TITLE'}
1037                     );
1038                     unless($getter->get($m)) {
1039                         _io(sprintf('%s>>> FAILED', _colorpair('*red')));
1040                     }
1041                 } elsif ('display' eq $mode) {
1042                     _io(
1043                         sprintf('%s>>> %sSaw %s%%s%s %s%%s',
1044                             _colorpair('*magenta'),
1045                             _colorpair(),
1046                             _colorpair('*yellow'),
1047                             _colorpair(),
1048                             _colorpair('*green')
1049                         ),
1050                         $m->{'SOURCE'},
1051                         $m->{'TITLE'}
1052                     );
1053                 } else {
1054                     _io(sprintf('%s>>> Invalid operation mode', _colorpair('*red')));
1055                 }
1056             }
1057
1058             # Remove the matched part from the message and try again (there may be
1059             # more!)
1060             $message =~ s/$p//;
1061             study($message);
1062             last GRABBER if ($message =~ /^\s*$/);
1063
1064             ($m, $p) = $g->get($message);
1065         }
1066     }
1067
1068     _pop_output();
1069 }
1070
1071 #
1072 # Handle a videosite command (/videosite ...) entered in the client
1073 #
1074 sub handle_command {
1075     my $event = shift;
1076     my ($cmd, @params) = split(/\s+/, $event->{message});
1077
1078     _push_output($event->{ewpf});
1079
1080     if (exists($videosite_commands->{$cmd})) {
1081         $videosite_commands->{$cmd}->(@params);
1082     }
1083
1084     _pop_output();
1085 }
1086
1087 1;