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