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