# (c) 2007 by Ralf Ertzinger <ralf@camperquake.de>
# licensed under GNU GPL v2
-package Base;
+package videosite::Base;
use strict;
+use LWP::UserAgent;
+use HTTP::Cookies;
use Data::Dumper;
sub new {
my $class = shift;
- my $self = {'_DEBUG' => 0, '_OUT' => sub {}};
-
+ my $self = {'_CONNECTOR' => undef,
+ _API => {
+ io => sub { print(@_) },
+ io_debug => sub { print(@_) },
+ 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;
}
sub error {
my $self = shift;
- my $t;
-
- $t = sprintf(shift(@_), @_);
- $t =~ s/%/%%/g;
- $self->{'_OUT'}->($t);
-}
-
-sub debug {
- my $self = shift;
my @data = @_;
- $data[0] = "DEBUG: " . $data[0];
- if ($self->{'_DEBUG'} != 0) {$self->error(@data)};
-}
-
-sub mergeconfig {
- my $self = shift;
- my $c = shift;
- my $o;
+ $data[0] = "(" . ref($self) . ") " . $data[0];
- 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'};
+ $self->{_API}->{io}->(@data);
}
-sub _prepare_parameters {
+sub debug {
my $self = shift;
- my $p;
+ my @data = @_;
- $self->{'_CONFIG'} = {'option' => {'enabled' => {'content' => '1'}}};
+ $data[0] = "(" . ref($self) . ") " . $data[0];
- foreach $p (keys(%{$self->{'_PARAMS'}})) {
- $self->{'_CONFIG'}->{'option'}->{$p}->{'content'} = $self->{'_PARAMS'}->{$p}->[0];
- }
+ $self->{_API}->{io_debug}->(@data);
}
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;
}
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->_getval($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";
return $s;
}
+# Return a list of the parameters supported by the module
+# Does not return the 'enabled' parameter
+sub getparamlist {
+ my $self = shift;
+ my $word = shift;
+
+ return grep {$_ ne 'enabled' && /^$word/} keys %{$self->{'_PARAMS'}};
+}
+
+# Return a list of valid parameter values, if the parameter has
+# such a list.
+sub getparamvalues {
+ my $self = shift;
+ my $param = shift;
+ my $word = shift;
+
+ unless(exists($self->{'_PARAMS'}->{$param}->[2])) {
+ return ();
+ } else {
+ return grep {/^$word/} keys %{$self->{'_PARAMS'}->{$param}->[2]};
+ }
+}
+
+
sub gethelpstr {
my $self = shift;
my $s = 'Help for ' . $self->{'NAME'} . ":\n";
}
$s .= " Options:\n";
- foreach $k (keys(%{$self->{'_CONFIG'}->{'option'}})) {
+ foreach $k (keys(%{$self->{'_PARAMS'}})) {
$p = $self->{'_PARAMS'}->{$k}->[0];
- $p =~ s/%/%%/g;
- $s .= sprintf(" %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
+ 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);
+ foreach (sort keys(%{$self->{'_PARAMS'}->{$k}->[2]})) {
+ $s .= sprintf(" %s: %s\n", $_, $self->{'_PARAMS'}->{$k}->[2]->{$_});
+ }
+ } else {
+ # The parameter just has a default value and a help text
+ $s .= sprintf(" %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
+ }
}
return $s;
}
-sub setdebug {
+sub ua {
+ my $self = shift;
+ my $ua;
+
+ $ua = LWP::UserAgent->new(
+ 'agent' => 'Mozilla/5.0',
+ 'cookie_jar' => HTTP::Cookies->new,
+ 'timeout' => 15,
+ );
+
+ # Remove a currently defined HTTPS proxy. See below for a longer explanation.
+ delete($ENV{'HTTPS_PROXY'});
+
+ if (defined($self->{'_CONNECTOR'})) {
+ my $schemas = $self->{'_CONNECTOR'}->{'schemas'};
+ foreach (keys(%{$schemas})) {
+ $self->debug("Adding schema %s with proxy %s", $_, $schemas->{$_});
+ if ($_ eq 'https') {
+ # OK, so here's the gist.
+ #
+ # The usual way of reqesting an HTTPS URL through a proxy is
+ # to connect to the proxy server, issue a CONNECT request to
+ # create a channel to the web server and start an SSL session over
+ # this channel, so there is an end-to-end connection between
+ # the client and the server.
+ #
+ # Setting a proxy for the https schema in LWP WILL NOT ACCOMPLISH
+ # THIS.
+ #
+ # LWP will connect to the proxy server, and issue a standard GET
+ # request for the target URL, which most proxy servers will refuse
+ # to get.
+ #
+ # The way to use a proxy server is to set some environment variables
+ # and let the underlying Crypt::SSLeay module do the rest.
+ #
+ # This is positively appaling.
+ $ENV{'HTTPS_PROXY'} = $schemas->{$_};
+ } else {
+ $ua->proxy($_, $schemas->{$_});
+ }
+ }
+ }
+
+ $self->{_CACHED_UA} = $ua;
+
+ return $ua;
+}
+
+sub _cached_ua {
+ my $self = shift;
+
+ return $self->{_CACHED_UA};
+}
+
+sub simple_get {
+ my $self = shift;
+ my $url = shift;
+ my $ua = shift || $self->ua();
+ my $r;
+
+ $r = $ua->get($url);
+ return $r->decoded_content() if $r->is_success();
+ return undef;
+}
+
+sub decode_hexurl {
+ my $self = shift;
+ my $d = shift;
+
+ $d =~ s/%([[:xdigit:]]{2})/chr(hex($1))/ge;
+
+ return $d;
+}
+
+sub decode_querystring {
+ my $self = shift;
+
+ return { map { split /=/, $_, 2; } split /&/, shift };
+}
+
+sub connectors {
+ my $self = shift;
+
+ return $self->{_API}->{connectors}->();
+}
+
+sub selectconn {
+ my $self = shift;
+
+ $self->{'_CONNECTOR'} = shift;
+}
+
+#
+# This function was used in previous versions of videosite. If it's called
+# we are dealing with an old plugin which probably needs some minor modifications
+# to work properly.
+#
+# Generate a warning message.
+#
+sub _prepare_parameters {
+ my $self = shift;
+
+ $self->error("THIS MODULE IS CALLING _prepare_parameters(). THIS FUNCTION IS DEPRECATED. See readme.txt in the plugin directory.");
+}
+
+#
+# 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.
+#
+sub register_api {
my $self = shift;
+ my $api = shift;
- $self->{'_DEBUG'} = shift;
+ $self->{_API} = $api;
}
1;
git://git.camperquake.de / videosite.git / blobdiff