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