libvideosite.pm

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