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