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