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