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