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