From: Ralf Ertzinger Date: Tue, 30 Apr 2013 13:51:23 +0000 (+0200) Subject: Manual merge for DailyMotionGrabber.pm X-Git-Url: https://git.camperquake.de/gitweb.cgi?p=videosite.git;a=commitdiff_plain;h=afe9b4975a8a82cec484ac15c73e7fd0c3c1dbbf;hp=9bb78db68a79470e45dd6400321e3dd96ffcb20b Manual merge for DailyMotionGrabber.pm --- diff --git a/libvideosite.pm b/libvideosite.pm new file mode 100644 index 0000000..4920801 --- /dev/null +++ b/libvideosite.pm @@ -0,0 +1,1047 @@ +package libvideosite; +require Exporter; + +use vars qw(@ISA @EXPORT_OK); +use File::Spec; +use Module::Load; +use LWP::UserAgent; +use Data::Dumper; +use File::Basename; +use Cwd qw(realpath); +use strict; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(init register_api check_for_link); + +my @outputstack; +my $outputprefix; +my $debug = 0; +my @grabbers; +my @getters; +my $getter; +my %builtin_config = (); +our $error; + +# +# The default config. These values will be set in the config +# if they do not exist already. +# +my $defaultconfig = { + 'getter' => 'filegetter', + 'mode' => 'download', + 'active-connectors' => 'direct', + 'defined-connectors' => 'direct', + 'connectors' => { + 'direct' => { + 'name' => 'direct', + '_immutable' => '1', + 'schemas' => {}, + } + } +}; + +# +# List of known commands and handlers +# +my $videosite_commands = { + 'save' => sub { + _cmd_save(); + }, + + 'set' => sub { + _cmd_set(@_); + }, + + 'show' => sub { + _cmd_show(@_); + }, + + 'help' => sub { + _cmd_help(@_); + }, + + 'getter' => sub { + _cmd_getter(@_); + }, + + 'enable' => sub { + _cmd_enable(@_); + }, + + 'disable' => sub { + _cmd_disable(@_); + }, + + 'reload' => sub { + init(); + }, + + 'mode' => sub { + _cmd_mode(@_); + }, + + 'connector' => sub { + _cmd_connector(@_); + }, + + 'debug' => sub { + $debug = 1; + foreach (@grabbers, @getters) { + $_->setdebug(1); + } + _io('Enabled debugging'); + }, + + 'nodebug' => sub { + $debug = 0; + foreach (@grabbers, @getters) { + $_->setdebug(0); + } + _io('Disabled debugging'); + }, +}; + +# +# This is a list of default values for the remote API. These +# are used if the values are not registered by the library user. +# +my $remote_api = { + io => sub { print @_, "\n" }, + config_init => \&_builtin_config_init, + config_get => \&_builtin_config_get, + config_set => \&_builtin_config_set, + config_has => \&_builtin_config_has, + config_save => \&_builtin_config_save, + config_del => \&_builtin_config_del, + color => sub { return '' }, + module_path => sub { return dirname(realpath($0)) }, + quote => sub { return $_ }, +}; + +# +# Output a string on the client. +# Works like (s)printf in that it takes a format string and a list of +# values to be replaced. Undefined values will be printed as '(undef)' +# +# All parameters (except for the format string itself) will be quoted +# using the client specific quote function +# +sub _io { + my @text = @_; + my $format; + + # This will define the outputprefix once, so we don't have + # do do this every time. + $outputprefix //= sprintf("%svideosite: %s", + $remote_api->{color}->('magenta'), + $remote_api->{color}->()); + $format = $outputprefix . shift(@text); + + # + # The format string is assumed to be appropriately quoted. + # Quote the rest of the text, replacing undefined strings by (undef) + # + @text = map { defined($_)?$remote_api->{quote}->($_):'(undef)' } @text; + + $outputstack[0]->(sprintf($format, @text)); +} + +# +# Recursively walk through a hash-of-hashes, calling the given function +# for each found leaf with the path to the leaf +# +sub _recursive_hash_walk { + my $hash = shift; + my $callback = shift; + my @path = @_; + + foreach (keys(%{$hash})) { + if (ref($hash->{$_}) eq 'HASH') { + _recursive_hash_walk($hash->{$_}, $callback, @path, $_); + } else { + $callback->([@path, $_], $hash->{$_}); + } + } +} + +# +# Return the color code for the given foreground/background color +# pair. Both can be undef, which means "default" +# +sub _colorpair { + my ($fg, $bg) = @_; + + return $remote_api->{color}->($fg, $bg); +} + +# +# Sets the given config item if it is not set already +# +sub _init_config_item { + my $path = shift; + my $value = shift; + + unless($remote_api->{config_has}->($path)) { + $remote_api->{config_set}->($path, $value); + } +} + +# +# Print a message if debug is enabled +# +sub _debug { + if ($debug) { + _io(@_); + } +} + +# +# Load a list of modules matching a pattern from a given directory. +# +sub _ploader { + + my $dir = shift; + my $pattern = shift; + my $type = shift; + my @list; + my $p; + my $g; + my @g = (); + + opendir(D, $dir) || return (); + @list = grep {/$pattern/ && -f File::Spec->catfile($dir, $_) } readdir(D); + closedir(D); + + foreach $p (@list) { + _debug("Trying to load $p:"); + $p =~ s/\.pm$//; + eval { + load "videosite::$p"; + }; + if ($@) { + _io("Failed to load plugin: $@"); + next; + } + + eval { + $g = "videosite::$p"->new(); + }; + if ($@) { + _io("Failed to instanciate: $@"); + delete($INC{$p}); + next; + } + + _debug("found $g->{'TYPE'} $g->{'NAME'}"); + if ($type eq $g->{'TYPE'}) { + push(@g, $g); + $g->register_api({ + io => \&_io, + connectors => sub { return _connectorlist('active-connectors') }, + config_get => \&_config_get, + config_set => \&_config_set, + config_has => \&_config_has, + }); + $g->setdebug($debug); + } else { + _io('%s has wrong type (got %s, expected %s)', $p, $g->{'TYPE'}, $type); + delete($INC{$p}); + } + } + + _debug("Loaded %d plugins", $#g+1); + + return @g; +} + +# +# Populate the @grabbers and @getters lists from the given +# directory +# +sub _load_modules($) { + + my $path = shift; + + foreach (keys(%INC)) { + if ($INC{$_} =~ m|^$path|) { + _debug("Removing %s from \$INC", $_); + delete($INC{$_}); + } + } + @grabbers = _ploader($path, '.*Grabber\.pm$', 'grabber'); + @getters = _ploader($path, '.*Getter\.pm$', 'getter'); +} + +# +# Wrapper functions for config management to put in +# debugging +# +sub _config_get { + my $path = shift; + my $value; + + $value = $remote_api->{config_get}->($path); + _debug("config: getting %s=%s", join('.', @{$path}), $value); + + return $value; +} + +sub _config_set { + my $path = shift; + my $value = shift; + + _debug("config: setting %s=%s", join('.', @{$path}), $value); + return $remote_api->{config_set}->($path, $value); +} + +sub _config_has { + my $path = shift; + my $b; + + $b = $remote_api->{config_has}->($path); + _debug("config: testing %s (%s)", join('.', @{$path}), $b?'true':'false'); + + return $b; +} + +# +# The _config_list_* are helper functions taking a path to a comma separated +# string. The string is interpreted as a list and the action performed +# on it, storing back the modified version +# + +# +# Add an item to the list, checking for duplicates +# +sub _config_list_add { + my $path = shift; + my $item = shift; + my @c; + + if (_config_has($path)) { + @c = split(/\s*,\s*/, _config_get($path)); + } else { + @c = (); + } + + _debug("Adding %s to list %s", $item, join(".", $path)); + unless(grep { $_ eq $item } @c) { + push(@c, $item); + }; + + _config_set($path, join(',', @c)); +} + +# +# Remove an item from the list +# +sub _config_list_del { + my $path = shift; + my $item = shift; + my @c; + + unless(_config_has($path)) { + return; + } + + _debug("Removing %s from list %s", $item, join('.', $path)); + @c = map { $item ne $_ } split(/\s*,\s*/, _config_get($path)); + + _config_set($path, join('.', @c)); +} + +# +# Return true if the item contains the given list, false otherwise +# +sub _config_list_has { + my $path = shift; + my $item = shift; + + unless(_config_has($path)) { + return 0; + } + + _debug("Checking for %s in list %s", $item, join('.', $path)); + + return grep { $item eq $_ } split(/\s*,\s*/, _config_get($path)); +} + +# +# Replace a list with the given items +# +sub _config_list_set { + my $path = shift; + + _debug("Replacing %s with (%s)", join('.', $path), join(",", @_)); + + _config_set($path, join(',', @_)); +} + +# +# Return the list of currently active connectors, in the configured +# order +# +sub _connectorlist { + my $key = shift; + my @c; + + foreach(split(/,/, _config_get([$key]))) { + push(@c, _unserialize_connector_hash($_)); + } + + return @c; +} + +# +# Convert a connector hash from it's config structure back to a perl +# hash +# +sub _unserialize_connector_hash { + my $name = shift; + my $connector = {}; + + if (_config_has(['connectors', $name, 'name'])) { + $connector->{name} = _config_get(['connectors', $name, 'name']); + $connector->{schemas} = {}; + foreach ('http', 'https') { + if (_config_has(['connectors', $name, 'schemas', $_])) { + $connector->{schemas}->{$_} = _config_get(['connectors', $name, 'schemas', $_]); + } + } + } + + _debug("Returning connector %s: %s", $name, Dumper($connector)); + + return $connector; +} + +# +# Push a new output function on the IO stack. +# +sub _push_output { + unshift(@outputstack, shift); +} + +# +# Pop the topmost output function from the stack, leaving +# at least one function on it. +# +sub _pop_output { + if (scalar(@outputstack) > 0) { + shift(@outputstack); + } +} + +# +# Takes a string and replaces commonly used URL shorteners recursively, +# up to 10 levels deep +# +sub _expand_url_shortener { + my $s = shift; + my $os = ''; + my @urlshortener = ( + 'is\.gd/[[:alnum:]]+', + 'otf\.me/[[:alnum:]]+', + 'hel\.me/[[:alnum:]]+', + '7ax\.de/[[:alnum:]]+', + 'ow\.ly/[[:alnum:]]+', + 'j\.mp/[[:alnum:]]+', + 'bit\.ly/[[:alnum:]]+', + 'tinyurl\.com/[[:alnum:]]+', + 'pop\.is/[[:alnum:]]+', + 'post\.ly/[[:alnum:]]+', + '1\.ly/[[:alnum:]]+', + '2\.ly/[[:alnum:]]+', + 't\.co/[[:alnum:]]+', + 'shar\.es/[[:alnum:]]+', + 'goo\.gl/[[:alnum:]]+', + ); + my $ua = LWP::UserAgent->new(agent => 'Mozilla', max_redirect => 0, timeout => 5); + my $i = 10; + + OUTER: while (($os ne $s) and ($i > 0)) { + study($s); + $os = $s; + $i--; + + foreach my $pattern (@urlshortener) { + my $p = "https?:\/\/" . $pattern; + + _debug("Matching %s against %s", $p, $s); + if ($s =~ m|($p)|) { + my $matched = $1; + my $res; + + _debug("Found %s", $matched); + $res = $ua->head($matched); + if ($res->is_redirect()) { + my $new = $res->headers()->header("Location"); + + _debug("Replacing %s with %s", $matched, $new); + $s =~ s/$matched/$new/; + next OUTER; + } else { + _debug("Error resolving %s", $matched); + } + } + } + } + + if ($i == 0) { + _debug("Loop terminated by counter"); + } + + _debug("Final string: %s", $s); + + return $s; +} + +# +# Save the config to durable storage +# +sub _cmd_save { + $remote_api->{config_save}->(); +} + +# +# Set a configuration element +# +sub _cmd_set { + my $target = shift; + my $key = shift; + my $val = shift; + my $p; + + foreach $p (@getters, @grabbers) { + if ($p->{'NAME'} eq $target) { + $p->setval($key, $val); + return; + } + } + _io('No such module'); +} + + +# +# Enable a given module +# +sub _cmd_enable { + my $target = shift; + my $p; + + foreach $p (@grabbers) { + if ($p->{'NAME'} eq $target) { + $p->enable(); + return; + } + } + _io('No such module'); +} + +# +# Disable given module +# +sub _cmd_disable { + my $target = shift; + my $p; + + foreach $p (@grabbers) { + if ($p->{'NAME'} eq $target) { + $p->disable(); + return; + } + } + _io('No such module'); +} + +# +# Show settings for modules +# +sub _cmd_show { + my $target = shift; + my $p; + my $e; + + if (defined($target)) { + foreach $p (@getters, @grabbers) { + if ($p->{'NAME'} eq $target) { + _io($p->getconfstr()); + return; + } + } + _io('No such module'); + } else { + _io('Loaded grabbers (* denotes enabled modules):'); + foreach $p (@grabbers) { + $e = $p->_getval('enabled'); + _io(' %s%s', $p->{'NAME'}, $e?'*':''); + }; + + _io('Loaded getters:'); + foreach $p (@getters) { + _io(' %s', $p->{'NAME'}); + }; + } +} + +# +# Show help for the commands +# +sub _cmd_help { + my $target = shift; + my $p; + + if (defined($target)) { + foreach $p (@getters, @grabbers) { + if ($p->{'NAME'} eq $target) { + _io($p->gethelpstr()); + return; + } + } + _io('No such module'); + } else { + _io(<<'EOT'); +Supported commands: + save: save the current configuration + help [modulename]: display this help, or module specific help + show [modulename]: show loaded modules, or the current parameters of a module + set modulename parameter value: set a module parameter to a new value + getter [modulename]: display or set the getter to use + enable [modulename]: enable the usage of this module (grabbers only) + disable [modulename]: disable the usage of this module (grabbers only) + reload: reload all modules (this is somewhat experimental) + mode [modename]: display or set the operation mode (download/display) + connector [subcommand]: manage connectors (proxies) + debug: enable debugging messages + nodebug: disable debugging messages +EOT + } +} + +# +# Set the getter to use +# +sub _cmd_getter { + my $target = shift; + my $p; + + if (defined($target)) { + foreach $p (@getters) { + if ($p->{'NAME'} eq $target) { + $getter = $p; + _config_set(['getter'], $target); + _io("Getter changed to %s", $target); + return; + } + } + _io('No such getter'); + } else { + _io('Current getter: %s', _config_get(['getter'])); + } +} + +# +# Show/set the working mode +# +sub _cmd_mode { + my $mode = shift; + + if (defined($mode)) { + $mode = lc($mode); + if (('download' eq $mode) or ('display' eq $mode)) { + _config_set(['mode'], $mode); + _io('Now using %s mode', $mode); + } else { + _io('Invalid mode: %s', $mode); + } + } else { + _io('Current mode: %s', _config_get(['mode'])); + } +} + + +# +# Manage the connectors +# +sub _cmd_connector { + my $subcmd = shift; + my $c; + + unless(defined($subcmd)) { + $subcmd = "help"; + } + + $subcmd = lc($subcmd); + + if ($subcmd eq 'list') { + _io("Defined connectors"); + foreach $c (_connectorlist('defined-connectors')) { + _io($c->{name}); + my $schemas = $c->{schemas}; + if (scalar(keys(%{$schemas})) == 0) { + _io(" No schemas defined"); + } else { + foreach (keys(%{$schemas})) { + _io(' %s: %s', $_, $schemas->{$_}); + } + } + } + + _io(); + _io("Selected connectors: %s", _config_get(['active-connectors'])); + } elsif ($subcmd eq 'add') { + my ($name) = @_; + + unless(defined($name)) { + _io("No name given"); + return; + } + + $name = lc($name); + + if (_config_list_has(['defined-connectors'], $name)) { + _io("Connector already exists"); + return; + } + + _config_set(['connectors', $name, 'name'], $name); + _config_list_add(['defined-connectors'], $name); + } elsif ($subcmd eq 'del') { + my ($name) = @_; + my @dcon; + + unless(defined($name)) { + _io("No name given"); + return; + } + + unless (_config_list_has(['defined-connectors'])) { + _io("Connector does not exist"); + return; + } + + if (_config_has(['connectors', $name, '_immutable'])) { + _io("Connector cannot be removed"); + return; + } + + # Remove from list of active connectors + _config_list_del(['defined-connectors'], $name); + _config_list_del(['active-connectors'], $name); + + _config_del(['connectors', $name, 'name']); + _config_del(['connectors', $name, '_immutable']); + _config_del(['connectors', $name, 'schemas', 'http']); + _config_del(['connectors', $name, 'schemas', 'https']); + + @dcon = split(/,/, _config_get(['active-connectors'])); + + if (scalar(@dcon) == 0) { + _io("List of selected connectors is empty, resetting to direct"); + _config_list_add(['active-connectors', 'direct']); + } + } elsif ($subcmd eq 'addschema') { + my ($conn, $schema, $proxy) = @_; + + unless(defined($conn)) { + _io("No connector name given"); + return; + } + + unless(defined($schema)) { + _io("No schema given"); + return; + } + + unless(defined($proxy)) { + _io("No proxy given"); + return; + } + + $conn = lc($conn); + unless(_config_list_has(['defined-connectors'], $conn)) { + _io("Connector does not exist"); + return; + } + + if (_config_has(['connectors', $conn, '_immutable'])) { + _io("Connector cannot be modified"); + return; + } + + $schema = lc($schema); + _config_set(['connectors', $conn, 'schemas', $schema], $proxy); + } elsif ($subcmd eq 'delschema') { + my ($conn, $schema) = @_; + + unless(defined($conn)) { + _io("No connector name given"); + return; + } + + unless(defined($schema)) { + _io("No schema given"); + return; + } + + $conn = lc($conn); + unless(_config_list_has(['defined-connectors'], $conn)) { + _io("Connector does not exist"); + return; + } + + $schema = lc($schema); + _config_del(['connectors', $conn, 'schemas', $schema]); + } elsif ($subcmd eq 'select') { + my @connlist = map { lc } @_; + + if (scalar(@connlist) == 0) { + _io("No connectors given"); + return; + } + + foreach (@connlist) { + unless(_config_list_has(['defined-connectors'], $_)) { + _io("Connector %s does not exist", $_); + return; + } + } + + _config_list_set(['active-connectors'], @connlist); + } else { + _io("connector [list|add|del|addschema|delschema|help] "); + _io(" help: Show this help"); + _io(" list: List the defined connectors"); + _io(" add : Add a connector with name "); + _io(" del : Delete the connector with name "); + _io(" addschema : Add proxy to connector for the given schema"); + _io(" delschema : Remove the schema from the connector"); + _io(" select [...]: Select the connectors to use"); + } +} + +# +# Return the list of loaded grabbers. +# This is used by the test programs, and is not meant to be +# used in general. +# +sub _grabbers { + return @grabbers; +} + +# +# ============================================== +# Builtin config handling functions +# These are used if the library used does not +# register it's own config_* handlers +# ============================================== +# +sub _builtin_config_init { +} + +sub _builtin_config_get { + return $builtin_config{join(".", @{$_[0]})}; +} + +sub _builtin_config_set { + $builtin_config{join(".", @{$_[0]})} = $_[1]; +} + +sub _builtin_config_has { + return exists($builtin_config{join(".", @{$_[0]})}); +} + +sub _builtin_config_save { +} + +sub _builtin_config_del { + delete($builtin_config{join(".", @{$_[0]})}); +} + +# +# ============================================== +# From this point on publicly callable functions +# ============================================== +# + + +# +# Initialization function for the library +# Actually not the first thing to be called, it expects an API +# has (register_api) to be registered first +# +sub init { + unless($remote_api) { + $error = "No API set"; + return 0; + } + + # Initialize configuration data + $remote_api->{config_init}->(); + + # Check/create default values, if they do not exist + _recursive_hash_walk($defaultconfig, \&_init_config_item); + + # Load modules + _load_modules(File::Spec->catfile($remote_api->{module_path}->(), 'videosite')); + + unless (@grabbers && @getters) { + _io('No grabbers or no getters found, can not proceed.'); + return 0; + } + + # Set the getter + $getter = $getters[0]; + foreach my $p (@getters) { + if (_config_get(['getter']) eq $p->{'NAME'}) { + $getter = $p; + } + } + _debug('Selected %s as getter', $getter->{'NAME'}); + _config_set(['getter'], $getter->{'NAME'}); + + # Done. + _io('initialized successfully'); + return 1; +} + +# +# Register a remote API. This API contains a basic output function (used +# when no window specific function is available), some config functions +# and a color code function. +# +sub register_api { + my $a = shift; + my @config_functions = qw(config_init config_set config_get config_has config_save config_del); + my $c; + my @missing; + + unless(defined($a)) { + die("No API given"); + } + + # + # The config_* handlers are special in that they either all have + # provided by the user, or none. In the latter case builtin + # handlers will be used, but the config will not persist. + # + $c = 0; + foreach (@config_functions) { + if (exists($a->{$_})) { + $c++; + } else { + push(@missing, $_); + } + } + + unless (($c == 0) or ($c == scalar(@config_functions))) { + $error = sprintf("Missing config function: %s", $missing[0]); + return 0; + } + + foreach (keys(%{$a})) { + if (ref($a->{$_}) ne 'CODE') { + $error = sprintf("API handler %s is not a subroutine reference", $_); + } + $remote_api->{$_} = $a->{$_}; + } + + if (exists($a->{_debug})) { + $debug = $a->{_debug}->(); + } + + @outputstack = ($remote_api->{'io'}); + + return 1; +} + +# +# Check a message for useable links +# +sub check_for_link { + my $event = shift; + my $message = $event->{message}; + my $g; + my $m; + my $p; + + + # Look if we should ignore this line + if ($message =~ m,(?:\s|^)/nosave(?:\s|$),) { + return; + } + + _push_output($event->{ewpf}); + $message = _expand_url_shortener($message); + + study($message); + + # Offer the message to all Grabbers in turn + GRABBER: foreach $g (@grabbers) { + ($m, $p) = $g->get($message); + while (defined($m)) { + _debug('Metadata: %s', Dumper($m)); + if (exists($remote_api->{link_callback})) { + $remote_api->{link_callback}->($m); + } + if ('download' eq _config_get(['mode'])) { + _io( + sprintf('%s>>> %sSaving %s%%s%s %s%%s', + $remote_api->{color}->('*red'), + $remote_api->{color}->(), + $remote_api->{color}->('*yellow'), + $remote_api->{color}->(), + $remote_api->{color}->('*green'), + ), + $m->{'SOURCE'}, + $m->{'TITLE'} + ); + unless($getter->get($m)) { + _io(sprintf('%s>>> FAILED', $remote_api->{color}->('*red'))); + } + } elsif ('display' eq _config_get(['mode'])) { + _io( + sprintf('%s>>> %sSaw %s%%s%s %s%%s', + $remote_api->{color}->('*magenta'), + $remote_api->{color}->(), + $remote_api->{color}->('*yellow'), + $remote_api->{color}->(), + $remote_api->{color}->('*green') + ), + $m->{'SOURCE'}, + $m->{'TITLE'} + ); + } else { + _io(sprintf('%s>>> Invalid operation mode', $remote_api->{color}->('*red'))); + } + + # Remove the matched part from the message and try again (there may be + # more!) + $message =~ s/$p//; + study($message); + last GRABBER if ($message =~ /^\s*$/); + + ($m, $p) = $g->get($message); + } + } + + _pop_output(); +} + +# +# Handle a videosite command (/videosite ...) entered in the client +# +sub handle_command { + my $event = shift; + my ($cmd, @params) = split(/\s+/, $event->{message}); + + _push_output($event->{ewpf}); + + if (exists($videosite_commands->{$cmd})) { + $videosite_commands->{$cmd}->(@params); + } + + _pop_output(); +} + +1; diff --git a/videosite-dl.pl b/videosite-dl.pl index 1b0079c..3a711f1 100755 --- a/videosite-dl.pl +++ b/videosite-dl.pl @@ -4,113 +4,59 @@ use strict; use Getopt::Long; use File::Spec; use File::Basename; +use Module::Load; use Cwd qw(realpath); -sub ploader { - - my $dir = shift; - my $pattern = shift; - my $type = shift; - my @list; - my $p; - my $g; - my @g = (); - - unshift(@INC, $dir); - - opendir(D, $dir) || return (); - @list = grep {/$pattern/ && -f File::Spec->catfile($dir, $_) } readdir(D); - closedir(D); - - foreach $p (@list) { - $p =~ s/\.pm$//; - eval qq{ require videosite::$p; }; - if ($@) { - print("Failed to load plugin: $@"); - next; - } - - $g = eval qq{ videosite::$p->new();}; - if ($@) { - print("Failed to instanciate: $@"); - delete($INC{$p}); - next; - } - - if ($type eq $g->{'TYPE'}) { - push(@g, $g); - } else { - printf('%s has wrong type (got %s, expected %s)', $p, $g->{'TYPE'}, $type); - delete($INC{$p}); +my $info = 0; +my $debug = 0; +my %config = ( + mode => 'download', + getter => 'filegetter', + 'plugin.youtube.QUALITY' => 'hd', + 'plugin.filegetter.FILEPATTERN' => './%3$s.flv', +); + +sub link_callback { + my $m = shift; + + if ($info) { + foreach (keys(%{$m})) { + printf("%s: %s\n", $_, defined($m->{$_})?$m->{$_}:'(undef)'); } + return 0; + } else { + print("Downloading $m->{'TITLE'}\n"); + return 1; } - - return @g; -} - -sub connectors { - my $c = {name => 'environment', schemas => {}}; - - if (exists($ENV{'http_proxy'})) { - $c->{schemas}->{'http'} = $ENV{'http_proxy'} - } - - if (exists($ENV{'https_proxy'})) { - $c->{schemas}->{'https'} = $ENV{'https_proxy'} - } - - return ( $c ); } -my $hq = 0; -my $ext = '.flv'; -my $y; -my $f; -my $m; -my @g; -my $bp; -my $info = 0; -my $debug = 0; - GetOptions("i" => \$info, "d" => \$debug); -# This is some dark magic to find out our real base directory, -# where we hope to find our plugins. -$bp = File::Spec->catdir(dirname(realpath($0)), 'videosite'); -unshift(@INC, dirname(realpath($0))); - -@g = ploader($bp, '.*Grabber\.pm$', 'grabber'); -($f) = ploader($bp, '^FileGetter\.pm$', 'getter'); - -unless(@g and defined($f)) { - print("No plugins could be loaded\n"); - exit 1; +push(@INC, dirname(realpath($0))); +load 'libvideosite'; + +unless(libvideosite::register_api({ + config_init => sub {}, + config_save => sub {}, + config_get => sub { return $config{join(".", @{$_[0]})} }, + config_set => sub { $config{join(".", @{$_[0]})} = $_[1] }, + config_has => sub { exists($config{join(".", @{$_[0]})}) }, + config_del => sub { delete($config{join(".", @{$_[0]})}) }, + link_callback => \&link_callback, + _debug => sub { return $debug }, +})) { + die("Error registering API: $libvideosite::error"); } -foreach (@g, $f) { - $_->setio(sub { printf(@_); print("\n"); } ); - $_->setconn(\&connectors); - - if ($debug) { - $_->setdebug(1); - } +unless(libvideosite::init()) { + die("Could not init libvideosite: $libvideosite::error"); } -$f->setval('FILEPATTERN', './%3$s' . $ext); - foreach (@ARGV) { - foreach $y (@g) { - ($m, undef) = $y->get($_); - if (defined($m)) { - if ($info) { - foreach (keys(%{$m})) { - printf("%s: %s\n", $_, defined($m->{$_})?$m->{$_}:'(undef)'); - } - } else { - print("Downloading $m->{'TITLE'}\n"); - $f->get($m); - } - } - } + printf("Handling %s...\n", $_); + libvideosite::check_for_link({ + message => $_, + ewpf => sub { print @_, "\n" }, + }); } diff --git a/videosite.pl b/videosite-irssi.pl similarity index 73% rename from videosite.pl rename to videosite-irssi.pl index 737ba82..f20e3a1 100644 --- a/videosite.pl +++ b/videosite-irssi.pl @@ -7,25 +7,12 @@ # which in turn is # based on trigger.pl by Wouter Coekaerts - -BEGIN { - # Get rid of a (possibly old) version of BettIrssi - # This is a hack to prevent having to reload irssi just - # because BettIrssi.pm changed - - delete($INC{'BettIrssi.pm'}); -} - use strict; use Irssi 20020324 qw (command_bind command_runsub signal_add_first signal_add_last); use vars qw($VERSION %IRSSI); -use XML::Simple; use Data::Dumper; use File::Spec; use File::Temp qw(tempfile); -use BettIrssi 101 qw(_bcb _bcs); -use LWP::UserAgent; -use JSON -support_by_pp; my @grabbers; my @getters; @@ -37,17 +24,6 @@ my $scriptdir = File::Spec->catfile(Irssi::get_irssi_dir(), 'scripts'); my $plugindir = File::Spec->catfile($scriptdir, 'videosite'); my @outputstack = (undef); -my $PARAMS = { - 'getter' => '', - 'mode' => 'download', - 'connectorlist' => ['direct'], - 'connectors' => {}, -}; - - -# activate debug here -my $debug = 0; - # "message public", SERVER_REC, char *msg, char *nick, char *address, char *target signal_add_last(_bcs("message public" => sub {check_for_link(@_)})); # "message own_public", SERVER_REC, char *msg, char *target @@ -780,18 +756,237 @@ sub sig_complete { Irssi::signal_stop(); } -sub cmdhandler { - my $event = shift; - my ($cmd, @params) = split(/\s+/, $event->message()); +# ================================= +# Reworked code below this line +# ================================= - push_output($event->ewpf); +# +# Initialize the config subsystem. Called by the core. +# +# Due to historic reasons this has to deal with a number of possible config sources: +# * irssi internal config +# * JSON config, old format +# * XML config, old format +# +# JSON and XML configs are parsed, converted and moved to the irssi internal +# format. This happens only once, as the config search stops with the first +# format found +# +sub config_init { + my $xmlconffile = File::Spec->catfile(Irssi::get_irssi_dir(), 'videosite.xml'); + my $conffile = File::Spec->catfile(Irssi::get_irssi_dir(), 'videosite.json'); + my $conf; + + # Check for irssi internal config. If not found... - if (exists($videosite_commands->{$cmd})) { - $videosite_commands->{$cmd}->(@params); + if (-r $conffile) { + write_debug("Attempting JSON config load from %s", $conffile); + eval { + local $/; + open(CONF, '<', $conffile); + $conf = JSON->new->utf8->decode(); + close(CONF); + }; + } elsif (-r $xmlconffile) { + write_debug("Attempting XML config load from %s", $xmlconffile); + $conf = XML::Simple::XMLin($xmlconffile, ForceArray => ['config', 'option', 'connectorlist'], KeepRoot => 1, KeyAttr => {'connector' => '+name', 'config' => 'module', 'option' => 'key'}); } - pop_output(); + # + # Configuration conversion: + # Replace this structure: + # + # key => { + # content => value + # } + # + # by this structure + # + # key => value + # + Irssi::print("Converting configuration, stage 1"); + + # Only the getter/grabbers have this, so just check that part of the config + foreach my $g (keys(%{$conf->{videosite}->{config}})) { + foreach (keys(%{$conf->{videosite}->{config}->{$g}->{option}})) { + if (exists($conf->{videosite}->{config}->{$g}->{option}->{$_}->{content})) { + $conf->{videosite}->{config}->{$g}->{option}->{$_} = $conf->{videosite}->{config}->{$g}->{option}->{$_}->{content}; + } + } + } + + # + # Walk the configuration hash, creating irssi config entries for + # each leaf node. + # + # Some config values changed, so not the entire config is copied over. + # There is a helper function for this in libvideosite that we're using. + # + Irssi::print("Converting configuration, stage 2"); + + # Copy the "basic" settings. + foreach (qw(getter mode)) { + config_set(['getter'], $conf->{videosite}->{$_}); + } + + # Copy the per-getter/setter settings + foreach my $g (keys(%{$conf->{videosite}->{config}})) { + foreach (keys(%{$conf->{videosite}->{config}->{$g}->{option}})) { + config_set(['plugin', $g, $_], $conf->{videosite}->{config}->{$g}->{option}->{$_}); + } + } + + # Copy the connectors. The connectors themselves are copied as-is, + # the list of active connectors is copied under a different name, + # and a list of all existing connectors is created + my @connectors; + + foreach my $c (keys(%{$conf->{videosite}->{connectors}})) { + push(@connectors, $c); + config_set(['connectors', $c, 'name'], $conf->{videosite}->{connectors}->{$c}->{name}); + if (exists($conf->{videosite}->{connectors}->{$c}->{_immutable})) { + config_set(['connectors', $c, '_immutable'], $conf->{videosite}->{connectors}->{$c}->{_immutable}); + } + foreach (qw(http https)) { + if (exists($conf->{videosite}->{connectors}->{$c}->{schemas}->{http})) { + config_set(['connectors', $c, 'schemas', $_], $conf->{videosite}->{connectors}->{$c}->{schemas_}->{$_}); + } + } + } + config_set(['active-connectors'], join(",", @{$conf->{connectorlist}})); + config_set(['defined-connectors'], join(",", @connectors)); +} + +# +# Reading a configuration value. Called by the core +# +sub config_get { + my $path = shift; + my $item = join('.', @{$path}); + my $val; + + + Irssi::settings_add_str('videosite', $item, "\0"); + $val = Irssi::settigs_get_str($item); + + return ($val ne "\0")?$val:undef; +} + +# +# Returns a true value if the config item exists +# +sub config_has { + my $path = shift; + my $item = join('.', @{$path}); + + Irssi::settings_add_str('videosite', $item, "\0"); + return Irssi::settings_get_str ne "\0"; +} + +# +# Setting a configuration value. Called by the core +# +sub config_set { + my $path = shift; + my $value = shift; + my $item = join('.', @{$path}); + + Irssi::settings_add_str('videosite', $item, "\0"); + Irssi::settings_set_str($item, $value); +} + +# +# Delete a configuration value. Called by the core. +# +sub config_del { + my $path = shift; + my $item = join('.', @{$path}); + + Irssi::settings_remove($item); +} + +# +# Return a color code. Called by the core +# +sub colorpair { + my ($fg, $bg) = @_; + + Irssi::print(sprintf("Asked to convert (%s,%s) into irssi color codes", $fg, $bg));o + + return ''; +} + +# +# Handle commands (/videosite ...) +# +sub videosite_hook { + my ($cmdline, $server, $witem) = @_; + my %event = ( + message => $cmdline, + ewpf => sub { defined($evitem)?$evitem->print(@_):Irssi::print(@_) }, + ); + + libvideosite::handle_command(\%event); +} + +# +# Handle a received message +# Create an event structure and hand it off to libvideosite +# +sub message_hook { + my ($server, $msg, $nick, $userhost, $channel) = @_; + my $evitem = $server->window_item_find($channel); + my %event = ( + message => $msg, + ewpf => sub { defined($evitem)?$evitem->print(@_):Irssi::print(@_) }, + ); + + libvideosite::check_for_link(\%event); +} + +sub videosite_reset { + unless(libvideosite::register_api({ + io => sub { Irssi::print(@_) }, + config_init => \&config_init, + config_get => \&config_get, + config_set => \&config_set, + config_has => \&config_has, + config_save => \&config_save, + config_del => \&config_del, + color => \&colorpair, + module_path => sub { return File::Spec->catfile(Irssi::get_irssi_dir(), 'scripts') }, + quote => sub { s/%/%%/g; return $_ }, + _debug => sub { 1 }, + })) { + Irssi::print(sprintf("videosite API register failed: %s", $libvideosite::error)); + return 0; + } + + unless(libvideosite::init()) { + Irssi::print(sprintf("videosite init failed: %s", $libvideosite::error)); + return 0; + } + + return 1; +} + +sub videosite_init { + # Find out the script directory, and add it to @INC. + # This is necessary to find libvideosite.pm + + push(@INC, File::Spec->catfile(Irssi::get_irssi_dir(), 'scripts')); + load 'libvideosite'; + + unless (videosite_reset()) { + signal_add_last("message public", sub { message_hook(@_) }); + signal_add_last("message own_public", sub { message_hook($_[0], $_[1], undef, undef, $_[2]) }); + signal_add_last("message private", sub { message_hooK($_[0], $_[1], $_[2], $_[3], $_[2]) }); + signal_add_last("message own_private", sub { message_hook($_[0], $_[1], undef, undef, $_[2]) }); + signal_add_last("message irc action", sub { message_hook(@_) }); + signal_add_last("message irc own_action", sub { message_hook($_[0], $_[1], undef, undef, $_[2]) }); + + Irssi::command_bind('videosite', sub { videosite_hook(@_) }); + } } -unshift(@INC, $scriptdir); -init_videosite(1); +videosite_init(); diff --git a/videosite-test.pl b/videosite-test.pl index 34b6f52..bfea2f2 100755 --- a/videosite-test.pl +++ b/videosite-test.pl @@ -4,103 +4,35 @@ use strict; use Getopt::Long; use File::Spec; use File::Basename; +use Module::Load; use Cwd qw(realpath); -sub ploader { - - my $dir = shift; - my $pattern = shift; - my $type = shift; - my @list; - my $p; - my $g; - my @g = (); - - unshift(@INC, $dir); - - opendir(D, $dir) || return (); - @list = grep {/$pattern/ && -f File::Spec->catfile($dir, $_) } readdir(D); - closedir(D); - - foreach $p (@list) { - $p =~ s/\.pm$//; - eval qq{ require videosite::$p; }; - if ($@) { - print("Failed to load plugin: $@"); - next; - } - - $g = eval qq{ videosite::$p->new();}; - if ($@) { - print("Failed to instanciate: $@"); - delete($INC{$p}); - next; - } - - if ($type eq $g->{'TYPE'}) { - push(@g, $g); - } else { - printf('%s has wrong type (got %s, expected %s)', $p, $g->{'TYPE'}, $type); - delete($INC{$p}); - } - } - - return @g; -} - -sub connectors { - my $c = {name => 'environment', schemas => {}}; - - if (exists($ENV{'http_proxy'})) { - $c->{schemas}->{'http'} = $ENV{'http_proxy'} - } - - if (exists($ENV{'https_proxy'})) { - $c->{schemas}->{'https'} = $ENV{'https_proxy'} - } - - return ( $c ); -} - - -my $hq = 0; -my $ext = '.flv'; -my $y; -my $f; -my $m; -my @g; -my $bp; my $debug = 0; -my ($success, $notest, $fail) = (0,0,0); - -GetOptions("d" => \$debug); - -# This is some dark magic to find out our real base directory, -# where we hope to find our plugins. -$bp = File::Spec->catdir(dirname(realpath($0)), 'videosite'); -unshift(@INC, dirname(realpath($0))); - -@g = ploader($bp, '.*Grabber\.pm$', 'grabber'); -($f) = ploader($bp, '^FileGetter\.pm$', 'getter'); - -unless(@g and defined($f)) { - print("No plugins could be loaded\n"); - exit 1; +my %config = ( + mode => 'download', + getter => 'filegetter', +); +my $success = 0; +my $fail = 0; +my $notest = 0; + +push(@INC, dirname(realpath($0))); +load 'libvideosite'; + +unless(libvideosite::register_api({ + _debug => sub { return $debug }, +})) { + die("Error registering API: $libvideosite::error"); } -foreach (@g, $f) { - $_->setio(sub { printf(@_); print("\n"); } ); - - if ($debug) { - $_->setdebug(1); - $_->setconn(\&connectors); - } +unless(libvideosite::init()) { + die("Could not init libvideosite: $libvideosite::error"); } select(STDOUT); $| = 1; printf("Doing self tests:\n"); -foreach(@g) { +foreach (libvideosite::_grabbers()) { my $r; printf(" %s...", $_->{'NAME'}); diff --git a/videosite-weechat.pl b/videosite-weechat.pl new file mode 100644 index 0000000..389a1fb --- /dev/null +++ b/videosite-weechat.pl @@ -0,0 +1,148 @@ +#!/usr/bin/perl -w + +use strict; +use File::Spec; +use Module::Load; +use Data::Dumper; + +weechat::register( + "videosite", + "Ralf Ertzinger (ralf\@skytale.net)", + "0.1", + "GPL", + "videosite Video URL grabber script (usage: /videosite)", + "", + ""); + +# +# Reading a configuration value. Called by the core +# +sub config_get { + my $path = shift; + my $item = join('.', @{$path}); + + if (weechat::config_is_set_plugin($item)) { + return weechat::config_get_plugin($item); + } else { + return undef; + } +} + +# +# Returns a true value if the config item exists +# +sub config_has { + my $path = shift; + my $item = join('.', @{$path}); + + return weechat::config_is_set_plugin($item); +} + +# +# Setting a configuration value. Called by the core +# +sub config_set { + my $path = shift; + my $value = shift; + my $item = join('.', @{$path}); + + weechat::config_set_plugin($item, $value); +} + +# +# Delete a configuration value. Called by the core. +# +sub config_del { + my $path = shift; + my $item = join('.', @{$path}); + + weechat::config_unset_plugin($item); +} + +# +# Return a color code. Called by the core +# +sub colorpair { + my ($fg, $bg) = @_; + + $fg //= 'default'; + $bg //= 'default'; + + return weechat::color($fg . ",", $bg); +} + +# +# Handle commands (/videosite ...) +# +sub videosite_hook { + my ($data, $buffer, $args) = @_; + my %event = ( + message => $args, + ewpf => sub { weechat::print($buffer, @_) }, + ); + + libvideosite::handle_command(\%event); + + return weechat::WEECHAT_RC_OK; +} + +# +# Handle a received message. +# Create an event structure and hand it off to libvideosite +# +sub message_hook { + my ($data, $buffer, $date, $tags, $displayed, $highlight, $prefix, $message ) = @_; + my %event = ( + message => $message, + ewpf => sub { weechat::print($buffer, @_) }, + ); + + libvideosite::check_for_link(\%event); + + return weechat::WEECHAT_RC_OK; +} + +# +# Reset the plugin +# +sub videosite_reset { + unless(libvideosite::register_api({ + io => sub { weechat::print("", @_) }, + config_init => sub {}, + config_get => \&config_get, + config_set => \&config_set, + config_has => \&config_has, + config_save => sub {}, + config_del => \&config_del, + color => \&colorpair, + module_path => sub { return File::Spec->catfile(weechat::info_get("weechat_dir", ""), 'perl') }, + quote => sub { return $_ }, + _debug => sub { 1 }, + })) { + weechat::print("", sprintf("videosite API register failed: %s", $libvideosite::error)); + return; + } + + unless(libvideosite::init()) { + weechat::print("", sprintf("videosite init failed: %s", $libvideosite::error)); + return; + } + + weechat::hook_print("", "notify_message", "://", 1, "message_hook", ""); + weechat::hook_print("", "notify_private", "://", 1, "message_hook", ""); + weechat::hook_print("", "notify_highlight", "://", 1, "message_hook", ""); + weechat::hook_print("", "notify_none", "://", 1, "message_hook", ""); + weechat::hook_command( "videosite", "videosite control functions", "", "", "", "videosite_hook", ""); +} + +sub videosite_init { + # Find out the script directory, and add it to @INC. + # This is necessary to find libvideosite.pm + + push(@INC, File::Spec->catfile(weechat::info_get("weechat_dir", ""), 'perl')); + load 'libvideosite'; + + videosite_reset(); +} + +videosite_init(); diff --git a/videosite/AsyncFileGetter.pm b/videosite/AsyncFileGetter.pm index 984597d..c47f9dd 100644 --- a/videosite/AsyncFileGetter.pm +++ b/videosite/AsyncFileGetter.pm @@ -20,14 +20,12 @@ use MIME::Base64; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'asyncfilegetter', + @_, + ); - $self->{'NAME'} = 'asyncfilegetter'; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub get { diff --git a/videosite/AsyncWgetFileGetter.pm b/videosite/AsyncWgetFileGetter.pm index d52a2ef..7a3642a 100644 --- a/videosite/AsyncWgetFileGetter.pm +++ b/videosite/AsyncWgetFileGetter.pm @@ -20,14 +20,12 @@ use MIME::Base64; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'asyncwgetfilegetter', + @_, + ); - $self->{'NAME'} = 'asyncwgetfilegetter'; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub get { diff --git a/videosite/Base.pm b/videosite/Base.pm index f6108f6..be0272e 100644 --- a/videosite/Base.pm +++ b/videosite/Base.pm @@ -11,16 +11,19 @@ use Data::Dumper; sub new { my $class = shift; my $self = {'_DEBUG' => 0, - '_OUT' => sub {printf(@_)}, - '_CONNECTORS' => sub { return ({ 'name' => 'direct', - 'schemas' => {} }) }, '_CONNECTOR' => undef, + API => { + io => sub { printf(@_) }, + connectors => sub { return ({ 'name' => 'direct', + 'schemas' => {} }) }, + }, + @_, }; + # Add the 'enabled' property to all modules + $self->{_PARAMS}->{enabled} = [1, 'Whether the module is enabled']; bless($self, $class); - $self->_prepare_parameters(); - return $self; } @@ -30,7 +33,7 @@ sub error { $data[0] = "(" . ref($self) . ") " . $data[0]; - $self->{'_OUT'}(@data); + $self->{_API}->{io}->(@data); } sub debug { @@ -41,41 +44,23 @@ sub debug { if ($self->{'_DEBUG'} != 0) {$self->error(@data)}; } -sub mergeconfig { - my $self = shift; - my $c = shift; - my $o; - - return $self->{'_CONFIG'} unless defined($c); - - foreach $o (keys(%{$c->{'option'}})) { - if (exists($self->{'_CONFIG'}->{'option'}->{$o})) { - $self->{'_CONFIG'}->{'option'}->{$o}->{'content'} = $c->{'option'}->{$o}->{'content'}; - } - } - - return $self->{'_CONFIG'}; -} - -sub _prepare_parameters { - my $self = shift; - my $p; - - $self->{'_CONFIG'} = {'option' => {'enabled' => {'content' => '1'}}}; - - foreach $p (keys(%{$self->{'_PARAMS'}})) { - $self->{'_CONFIG'}->{'option'}->{$p}->{'content'} = $self->{'_PARAMS'}->{$p}->[0]; - } -} - sub _getval { my $self = shift; my $key = shift; + my $path = ['plugin', $self->{NAME}, $key]; my $val; - $val = $self->{'_CONFIG'}->{'option'}->{$key}->{'content'}; - $self->debug('Returning %s=%s', $key, $val); + # Try to read from the global config + # Fall back to default + if ($self->{_API}->{config_has}->($path)) { + $val = $self->{_API}->{config_get}->($path); + } elsif (exists($self->{_PARAMS}->{$key})) { + $val = $self->{_PARAMS}->{$key}->[0]; + } else { + $self->error('Requested unknown config key %s', $key); + } + $self->debug('Returning %s=%s', $key, $val); return $val; } @@ -83,32 +68,25 @@ sub setval { my $self = shift; my $key = shift; my $val = shift; + my $path = ['plugin', $self->{NAME}, $key]; - if (exists($self->{'_CONFIG'}->{'option'}->{$key})) { - $self->{'_CONFIG'}->{'option'}->{$key}->{'content'} = $val; + if (exists($self->{'_PARAMS'}->{$key})) { + $self->{_API}->{config_set}->($path, $val); } else { - $self->error('Module %s does not have a parameter named %s', $self->{'NAME'}, $key); + $self->error('Module does not have a parameter named %s', $self->$key); } } -sub setio { - my $self = shift; - my $io = shift; - - $self->{'_OUT'} = $io; -} - sub getconfstr { my $self = shift; my $s = 'Options for ' . $self->{'NAME'} . ":\n"; my $k; my $p; - foreach $k (keys(%{$self->{'_CONFIG'}->{'option'}})) { - $p = $self->{'_CONFIG'}->{'option'}->{$k}->{'content'}; - $p =~ s/%/%%/g; + foreach $k (keys(%{$self->{'_PARAMS'}})) { + $p = $self->{_API}->{config_get}->{$k}; $s .= sprintf(" %s: %s", $k, $p); - if ($self->{'_CONFIG'}->{'option'}->{$k}->{'content'} eq $self->{'_PARAMS'}->{$k}->[0]) { + if ($p eq $self->{'_PARAMS'}->{$k}->[0]) { $s .= " (default)\n"; } else { $s .= "\n"; @@ -153,9 +131,8 @@ sub gethelpstr { } $s .= " Options:\n"; - foreach $k (keys(%{$self->{'_CONFIG'}->{'option'}})) { + foreach $k (keys(%{$self->{'_PARAMS'}})) { $p = $self->{'_PARAMS'}->{$k}->[0]; - $p =~ s/%/%%/g; if (exists($self->{'_PARAMS'}->{$k}->[2])) { # The parameter has a list of allowed values. Add the keys and their help $s .= sprintf(" %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p); @@ -261,7 +238,7 @@ sub decode_querystring { sub connectors { my $self = shift; - return $self->{'_CONNECTORS'}->(); + return $self->{_API}->{connectors}->(); } sub selectconn { @@ -270,10 +247,19 @@ sub selectconn { $self->{'_CONNECTOR'} = shift; } -sub setconn { +# +# Register a callbacks into the core API to the plugin. +# Example of those are config getter/setters and IO functions +# The API is a hash reference containing subroutine references. +# +# After the API is registered an attempt is made to load the config +# (or set defaults if config values are not found) +# +sub register_api { my $self = shift; + my $api = shift; - $self->{'_CONNECTORS'} = shift; + $self->{_API} = $api; } 1; diff --git a/videosite/BlipTVGrabber.pm b/videosite/BlipTVGrabber.pm index 2a48541..86084dd 100644 --- a/videosite/BlipTVGrabber.pm +++ b/videosite/BlipTVGrabber.pm @@ -16,17 +16,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'bliptv'; - $self->{_SELFTESTURL} = 'http://blip.tv/rebelliouspixelscom/buffy-vs-edward-twilight-remixed-2274024'; - $self->{_SELFTESTTITLE} = 'Buffy vs Edward (Twilight Remixed)'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*blip.tv/\S+/\S+)']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'bliptv', + _SELFTESTURL => 'http://blip.tv/rebelliouspixelscom/buffy-vs-edward-twilight-remixed-2274024', + _SELFTESTTITLE => 'Buffy vs Edward (Twilight Remixed)', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*blip.tv/\S+/\S+)'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/BreakGrabber.pm b/videosite/BreakGrabber.pm index 0896078..6bd77e1 100644 --- a/videosite/BreakGrabber.pm +++ b/videosite/BreakGrabber.pm @@ -15,16 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'break', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*break.com/index/([-a-zA-Z0-9_]+?)\.html)'], + @_, + ); - $self->{'NAME'} = 'break'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*break.com/index/([-a-zA-Z0-9_]+?)\.html)']; - - bless($self, $class); - - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/BroadcasterGrabber.pm b/videosite/BroadcasterGrabber.pm index 5891acb..4c37101 100644 --- a/videosite/BroadcasterGrabber.pm +++ b/videosite/BroadcasterGrabber.pm @@ -15,15 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'broadcaster', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*broadcaster\.com/clip/(\d+))'], + @_, + ); - $self->{'NAME'} = 'broadcaster'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*broadcaster\.com/clip/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/CollegeHumorGrabber.pm b/videosite/CollegeHumorGrabber.pm index 7fb3cae..c7851e3 100644 --- a/videosite/CollegeHumorGrabber.pm +++ b/videosite/CollegeHumorGrabber.pm @@ -16,18 +16,16 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'collegehumor'; - $self->{_SELFTESTURL} = 'http://www.collegehumor.com/video/5635400/pixar-intro-parody'; - $self->{_SELFTESTTITLE} = 'Pixar Intro Parody'; - $self->{'PATTERNS'} = ['(http://www.collegehumor.com/video:(\d+))', - '(http://www.collegehumor.com/video/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'collegehumor', + _SELFTESTURL => 'http://www.collegehumor.com/video/5635400/pixar-intro-parody', + _SELFTESTTITLE => 'Pixar Intro Parody', + PATTERNS => ['(http://www.collegehumor.com/video:(\d+))', + '(http://www.collegehumor.com/video/(\d+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/DailyMotionGrabber.pm b/videosite/DailyMotionGrabber.pm index fc1f08c..74e5030 100644 --- a/videosite/DailyMotionGrabber.pm +++ b/videosite/DailyMotionGrabber.pm @@ -16,18 +16,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'dailymotion'; - $self->{_SELFTESTURL} = 'http://www.dailymotion.com/video/xylv6u_moon-duo-sleepwalker_music'; - $self->{_SELFTESTTITLE} = 'Moon Duo - Sleepwalker'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*dailymotion.com/(?:[^/]+/)*video/([-a-zA-Z0-9_]+))']; - - bless($self, $class); - - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'dailymotion', + _SELFTESTURL => 'http://www.dailymotion.com/video/xylv6u_moon-duo-sleepwalker_music', + _SELFTESTTITLE => 'Moon Duo - Sleepwalker', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*dailymotion.com/(?:[^/]+/)*video/([-a-zA-Z0-9_]+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/DoubleVikingGrabber.pm b/videosite/DoubleVikingGrabber.pm index e79c261..027395e 100644 --- a/videosite/DoubleVikingGrabber.pm +++ b/videosite/DoubleVikingGrabber.pm @@ -15,15 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'doubleviking', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*doubleviking.com/videos/(?:[-a-zA-Z0-9_ %]+/)*page0\.html/(\d+)\.html$)'], + @_, + ); - $self->{'NAME'} = 'doubleviking'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*doubleviking.com/videos/(?:[-a-zA-Z0-9_ %]+/)*page0\.html/(\d+)\.html$)']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/FileGetter.pm b/videosite/FileGetter.pm index f7c680e..b2a0cea 100644 --- a/videosite/FileGetter.pm +++ b/videosite/FileGetter.pm @@ -14,15 +14,16 @@ use File::Basename; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'filegetter'; - $self->{'_PARAMS'} = {'MINFREE' => ['500000', 'The amount of space that needs to be available on the filesystem before the video is downloaded (in kilobytes)'], 'FILEPATTERN', => ['/tmp/%s - %s - %s.flv', "The file name to save the file under. This is a string which is passed to a sprintf call later on. The parameters passed to that sprintf call, in order, are:\n- The site the video is from\n- The ID of the video\n- The title of the video\n- The URL of the video file itself\n- The URL of the site the video was taken from\nAll parameters are encoded (space and / replaced by _)"]}; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'filegetter', + _PARAMS => { + MINFREE => ['500000', 'The amount of space that needs to be available on the filesystem before the video is downloaded (in kilobytes)'], + FILEPATTERN => ['/tmp/%s - %s - %s.flv', "The file name to save the file under. This is a string which is passed to a sprintf call later on. The parameters passed to that sprintf call, in order, are:\n- The site the video is from\n- The ID of the video\n- The title of the video\n- The URL of the video file itself\n- The URL of the site the video was taken from\nAll parameters are encoded (space and / replaced by _)"] + }, + @_, + ); + + return bless($self, $class); } sub get { diff --git a/videosite/GetterBase.pm b/videosite/GetterBase.pm index c7d56de..52e8a4d 100644 --- a/videosite/GetterBase.pm +++ b/videosite/GetterBase.pm @@ -10,12 +10,11 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self = {%{$self}, + my $self = $class->SUPER::new( NAME => 'FlashGetter', - TYPE => 'getter' - }; + TYPE => 'getter', + @_, + ); return bless($self, $class); } diff --git a/videosite/GoogleGrabber.pm b/videosite/GoogleGrabber.pm index 4915603..51d0e2e 100644 --- a/videosite/GoogleGrabber.pm +++ b/videosite/GoogleGrabber.pm @@ -15,16 +15,16 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'google'; - $self->{'PATTERNS'} = ['(http://video\.google\.com/videoplay\?docid=([-\d]+))']; - $self->{'_PARAMS'} = {'QUALITY' => ['normal', 'Quality of the video to download. normal = standard resolution flash video, h264 = high resolution MPEG4 video']}; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'google', + PATTERNS => ['(http://video\.google\.com/videoplay\?docid=([-\d]+))'], + _PARAMS => { + QUALITY => ['normal', 'Quality of the video to download. normal = standard resolution flash video, h264 = high resolution MPEG4 video'] + }, + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/GrabberBase.pm b/videosite/GrabberBase.pm index 44bde35..576d7e4 100644 --- a/videosite/GrabberBase.pm +++ b/videosite/GrabberBase.pm @@ -11,13 +11,12 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self = {%{$self}, + my $self = $class->SUPER::new( NAME => 'FlashGrab', TYPE => 'grabber', PATTERNS => [], - }; + @_, + ); return bless($self, $class); } diff --git a/videosite/HTTPJSONGetter.pm b/videosite/HTTPJSONGetter.pm index 87a6d83..4db0ed8 100644 --- a/videosite/HTTPJSONGetter.pm +++ b/videosite/HTTPJSONGetter.pm @@ -14,15 +14,15 @@ use JSON -support_by_pp; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'HTTPJSONGetter'; - $self->{'_PARAMS'} = {'URL' => ['http://www.example.com/getjson.pl', "The URL to call in order to trigger a download. The JSON encoded information will be POSTed to this URL."]}; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'HTTPJSONGetter', + _PARAMS => { + URL => ['http://www.example.com/getjson.pl', "The URL to call in order to trigger a download. The JSON encoded information will be POSTed to this URL."] + }, + @_, + ); + + return bless($self, $class); } sub get { diff --git a/videosite/HTTPRPCGetter.pm b/videosite/HTTPRPCGetter.pm index 16ef726..e82e218 100644 --- a/videosite/HTTPRPCGetter.pm +++ b/videosite/HTTPRPCGetter.pm @@ -14,15 +14,15 @@ use LWP::Simple qw(!get); sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'HTTPRPCGetter'; - $self->{'_PARAMS'} = {'URL' => ['http://www.example.com/get.pl?type=%s&vid=%s&title=%s&url=%s', "The URL to call in order to trigger a download. This is a string which is passed to a sprintf call later on. The parameters passed to that sprintf call, in order, are:\n- The site the video is from\n- The ID of the video\n- The title of the video\n- The URL of the video file itself\n- The URL of the site the video was taken from\nAll parameters are hexencoded"]}; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'HTTPRPCGetter', + _PARAMS => { + URL => ['http://www.example.com/get.pl?type=%s&vid=%s&title=%s&url=%s', "The URL to call in order to trigger a download. This is a string which is passed to a sprintf call later on. The parameters passed to that sprintf call, in order, are:\n- The site the video is from\n- The ID of the video\n- The title of the video\n- The URL of the video file itself\n- The URL of the site the video was taken from\nAll parameters are hexencoded"] + }, + @_, + ); + + return bless($self, $class); } sub get { diff --git a/videosite/LiveLeakGrabber.pm b/videosite/LiveLeakGrabber.pm index 27f4c7f..4521f37 100644 --- a/videosite/LiveLeakGrabber.pm +++ b/videosite/LiveLeakGrabber.pm @@ -15,15 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'liveleak', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*liveleak.com/view\?i=([^\&]+))'], + @_, + ); - $self->{'NAME'} = 'liveleak'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*liveleak.com/view\?i=([^\&]+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/MNCastGrabber.pm b/videosite/MNCastGrabber.pm index 19c1969..45954f9 100644 --- a/videosite/MNCastGrabber.pm +++ b/videosite/MNCastGrabber.pm @@ -16,15 +16,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'mncast', + PATTERNS => ['(http://www\.mncast\.com/\?(\d+))'], + @_, + ); - $self->{'NAME'} = 'mncast'; - $self->{'PATTERNS'} = ['(http://www\.mncast\.com/\?(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/MetaCafeGrabber.pm b/videosite/MetaCafeGrabber.pm index e134bec..ccab7a9 100644 --- a/videosite/MetaCafeGrabber.pm +++ b/videosite/MetaCafeGrabber.pm @@ -15,16 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'metacafe', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*metacafe.com/watch/(\d+)(?:\S+)?)'], + @_, + ); - $self->{'NAME'} = 'metacafe'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*metacafe.com/watch/(\d+)(?:\S+)?)']; - - bless($self, $class); - - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/MotherlessGrabber.pm b/videosite/MotherlessGrabber.pm index bbbe1a8..681b733 100644 --- a/videosite/MotherlessGrabber.pm +++ b/videosite/MotherlessGrabber.pm @@ -17,17 +17,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'motherless'; - $self->{_SELFTESTURL} = 'http://motherless.com/4976432'; - $self->{_SELFTESTTITLE} = 'Teen masturbation in shower'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*motherless.com/([a-zA-Z0-9]+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'motherless', + _SELFTESTURL => 'http://motherless.com/4976432', + _SELFTESTTITLE => 'Teen masturbation in shower', + _PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*motherless.com/([a-zA-Z0-9]+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/MyVideoGrabber.pm b/videosite/MyVideoGrabber.pm index 3028466..7be3806 100644 --- a/videosite/MyVideoGrabber.pm +++ b/videosite/MyVideoGrabber.pm @@ -15,15 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'myvideo', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*myvideo.de/watch/(\d+))'], + @_, + ); - $self->{'NAME'} = 'myvideo'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*myvideo.de/watch/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/NullGetter.pm b/videosite/NullGetter.pm index 28e62f5..3a16c0c 100644 --- a/videosite/NullGetter.pm +++ b/videosite/NullGetter.pm @@ -14,14 +14,12 @@ use LWP::Simple qw(!get); sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'nullgetter', + @_, + ); - $self->{'NAME'} = 'nullgetter'; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub get { diff --git a/videosite/RedTubeGrabber.pm b/videosite/RedTubeGrabber.pm index df01837..72036b8 100644 --- a/videosite/RedTubeGrabber.pm +++ b/videosite/RedTubeGrabber.pm @@ -18,17 +18,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'redtube'; - $self->{_SELFTESTURL} = 'http://www.redtube.com/8269'; - $self->{_SELFTESTTITLE} = 'Porn bloopers with pretty girl'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*redtube.com/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'redtube', + _SELFTESTURL => 'http://www.redtube.com/8269', + _SELFTESTTITLE => 'Porn bloopers with pretty girl', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*redtube.com/(\d+))'], + @_, + ); + + return bless($self, $class); } sub div($$) { diff --git a/videosite/SevenloadGrabber.pm b/videosite/SevenloadGrabber.pm index 4d3482f..f58c00e 100644 --- a/videosite/SevenloadGrabber.pm +++ b/videosite/SevenloadGrabber.pm @@ -15,17 +15,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'sevenload'; - $self->{_SELFTESTURL} = 'http://de.sevenload.com/videos/uqDvKzh-vilogo-TV-Spot'; - $self->{_SELFTESTTITLE} = 'vilogo TV-Spot'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*sevenload.com/videos/(\w+?)-.*)']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'sevenload', + _SELFTESTURL => 'http://de.sevenload.com/videos/uqDvKzh-vilogo-TV-Spot', + _SELFTESTTITLE => 'vilogo TV-Spot', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*sevenload.com/videos/(\w+?)-.*)'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/SnotrGrabber.pm b/videosite/SnotrGrabber.pm index 3009995..87b7a10 100644 --- a/videosite/SnotrGrabber.pm +++ b/videosite/SnotrGrabber.pm @@ -15,17 +15,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'snotr'; - $self->{_SELFTESTURL} = 'http://www.snotr.com/video/1836'; - $self->{_SELFTESTTITLE} = 'Brilliant thief'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*snotr\.com/video/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'snotr', + _SELFTESTURL => 'http://www.snotr.com/video/1836', + _SELFTESTTITLE => 'Brilliant thief', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*snotr\.com/video/(\d+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/SpikedHumorGrabber.pm b/videosite/SpikedHumorGrabber.pm index 5d0f6ae..880263f 100644 --- a/videosite/SpikedHumorGrabber.pm +++ b/videosite/SpikedHumorGrabber.pm @@ -15,15 +15,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'spikedhumor', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*spikedhumor.com/articles/(\d+)(?:/.*)*)'], + @_, + ); - $self->{'NAME'} = 'spikedhumor'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*spikedhumor.com/articles/(\d+)(?:/.*)*)']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/VeohGrabber.pm b/videosite/VeohGrabber.pm index dda2b5d..c33f1d8 100644 --- a/videosite/VeohGrabber.pm +++ b/videosite/VeohGrabber.pm @@ -14,17 +14,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'veoh'; - $self->{_SELFTESTURL} = 'http://www.veoh.com/watch/v18348952fyn2twbe'; - $self->{_SELFTESTTITLE} = '518_2 kureyon shinchan'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*veoh.com/+watch/(\w+)\??)']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'veoh', + _SELFTESTURL => 'http://www.veoh.com/watch/v18348952fyn2twbe', + _SELFTESTTITLE => '518_2 kureyon shinchan', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*veoh.com/+watch/(\w+)\??)'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/VimeoGrabber.pm b/videosite/VimeoGrabber.pm index 9b2b689..19dfe94 100644 --- a/videosite/VimeoGrabber.pm +++ b/videosite/VimeoGrabber.pm @@ -16,17 +16,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'vimeo'; - $self->{_SELFTESTURL} = 'http://vimeo.com/35055590'; - $self->{_SELFTESTTITLE} = 'Hello'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*vimeo.com/(?:m/)?(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'vimeo', + _SELFTESTURL => 'http://vimeo.com/35055590', + _SELFTESTTITLE => 'Hello', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*vimeo.com/(?:m/)?(\d+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/WimpGrabber.pm b/videosite/WimpGrabber.pm index e9b14ff..cffc02c 100644 --- a/videosite/WimpGrabber.pm +++ b/videosite/WimpGrabber.pm @@ -16,18 +16,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'wimp'; - $self->{_SELFTESTURL} = 'http://www.wimp.com/insanebuilding/'; - $self->{_SELFTESTTITLE} = 'Insane building.'; - $self->{'PATTERNS'} = ['(http://(?:[-a-zA-Z0-9_.]+\.)*wimp.com/([^/]+)/?)']; - - bless($self, $class); - - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'wimp', + _SELFTESTURL => 'http://www.wimp.com/insanebuilding/', + _SELFTESTTITLE => 'Insane building.', + PATTERNS => ['(http://(?:[-a-zA-Z0-9_.]+\.)*wimp.com/([^/]+)/?)'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/YahooGrabber.pm b/videosite/YahooGrabber.pm index fc88043..4c88842 100644 --- a/videosite/YahooGrabber.pm +++ b/videosite/YahooGrabber.pm @@ -16,15 +16,13 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); + my $self = $class->SUPER::new( + NAME => 'yahoo', + PATTERNS => ['(http://video\.yahoo\.com/watch/\d+/(\d+))'], + @_, + ); - $self->{'NAME'} = 'yahoo'; - $self->{'PATTERNS'} = ['(http://video\.yahoo\.com/watch/\d+/(\d+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + return bless($self, $class); } sub _parse { diff --git a/videosite/YouTubeGrabber.pm b/videosite/YouTubeGrabber.pm index 10b1c2e..28f5007 100644 --- a/videosite/YouTubeGrabber.pm +++ b/videosite/YouTubeGrabber.pm @@ -53,34 +53,33 @@ my %videoformats = ( sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'youtube'; - $self->{_SELFTESTURL} = 'http://www.youtube.com/watch?v=dMH0bHeiRNg'; - $self->{_SELFTESTTITLE} = 'Evolution of Dance - By Judson Laipply'; - $self->{'PATTERNS'} = ['(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/watch(?:_popup)?\?.*?v=([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/watch\#\!v=([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/v/([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/embed/([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/user/[[:alnum:]]+\?v=([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/(?:user/)?[[:alnum:]]+#p/(?:\w+/)+\d+/([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtu\.be/watch\?v=([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtu\.be/([-a-zA-Z0-9_]+))', - '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/user/\w+\?.*/([-a-zA-Z0-9_]+))']; - $self->{'_PARAMS'} = { - 'QUALITY' => ['normal', 'Quality of the video to download.', { - 'normal' => 'standard resolution flash video', - 'high' => 'higher resolution flash video', - 'h264' => 'high resolution MPEG4 video', - 'hd' => 'HD720 resolution'}], - 'USERNAME' => ['', 'Username to use for YouTube login'], - 'PASSWORD' => ['', 'Password to use for YouTube login'], - 'HTTPS' => [1, 'Whether to use HTTPS (if available) to connect to YouTube']}; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'youtube', + _SELFTESTURL => 'http://www.youtube.com/watch?v=dMH0bHeiRNg', + _SELFTESTTITLE => 'Evolution of Dance - By Judson Laipply', + PATTERNS => ['(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/watch(?:_popup)?\?.*?v=([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/watch\#\!v=([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/v/([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/embed/([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/user/[[:alnum:]]+\?v=([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/(?:user/)?[[:alnum:]]+#p/(?:\w+/)+\d+/([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtu\.be/watch\?v=([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtu\.be/([-a-zA-Z0-9_]+))', + '(https?://(?:[-a-zA-Z0-9_.]+\.)*youtube\.(?:com|de|co.uk)/user/\w+\?.*/([-a-zA-Z0-9_]+))'], + _PARAMS => { + QUALITY => ['normal', 'Quality of the video to download.', { + normal => 'standard resolution flash video', + high => 'higher resolution flash video', + h264 => 'high resolution MPEG4 video', + hd => 'HD720 resolution'}], + USERNAME => ['', 'Username to use for YouTube login'], + PASSWORD => ['', 'Password to use for YouTube login'], + HTTPS => [1, 'Whether to use HTTPS (if available) to connect to YouTube'] + }, + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/ZeroPunctuationGrabber.pm b/videosite/ZeroPunctuationGrabber.pm index a9538fe..f40da05 100644 --- a/videosite/ZeroPunctuationGrabber.pm +++ b/videosite/ZeroPunctuationGrabber.pm @@ -16,17 +16,15 @@ use strict; sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'NAME'} = 'zeropunctuation'; - $self->{_SELFTESTURL} = 'http://www.escapistmagazine.com/videos/view/zero-punctuation/5346-Amy'; - $self->{_SELFTESTTITLE} = 'Amy'; - $self->{'PATTERNS'} = ['(http://www.escapistmagazine.com/videos/view/zero-punctuation/([-A-Za-z0-9]+))']; - - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + NAME => 'zeropunctuation', + _SELFTESTURL => 'http://www.escapistmagazine.com/videos/view/zero-punctuation/5346-Amy', + _SELFTESTTITLE =>'Amy', + PATTERNS => ['(http://www.escapistmagazine.com/videos/view/zero-punctuation/([-A-Za-z0-9]+))'], + @_, + ); + + return bless($self, $class); } sub _parse { diff --git a/videosite/readme.txt b/videosite/readme.txt index 943e430..697ff42 100644 --- a/videosite/readme.txt +++ b/videosite/readme.txt @@ -143,20 +143,13 @@ declared as follows: sub new { my $class = shift; - my $self = $class->SUPER::new(); - - $self->{'_PARAMS'} = {'FOO' => [42, 'This is the FOO parameter, twiddle it to do stuff']}; - bless($self, $class); - $self->_prepare_parameters(); - - return $self; + my $self = $class->SUPER::new( + _PARAMS => {'FOO' => [42, 'This is the FOO parameter, twiddle it to do stuff']}, + @_, + ); + return bless($self, $class); } -b) as seen in the example above, after declaring the parameter hash, call the -method _prepare_parameters() on your class instance. This will convert the -hash into the internally used data structure and prepare it for automatic -loading and saving. - -c) to access one of the parameters, call the _getval() method, giving the name +b) to access one of the parameters, call the _getval() method, giving the name of the parameter as first argument. This will return the current value of that -parameter (either the default value or the user defuned value). +parameter (either the default value or the user defined value).