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