X-Git-Url: https://git.camperquake.de/gitweb.cgi?p=videosite.git;a=blobdiff_plain;f=videosite%2FBase.pm;h=437ef98839b0e5232e1cfbdf8fa16f952e2eb5b1;hp=cad437428f4eb4509aab67701f72a50a573a37ba;hb=ba7da213efc2779e513a1b8c535a5a89283527c8;hpb=844f3a7ee84b480f3a23b328259bd2fc69981066 diff --git a/videosite/Base.pm b/videosite/Base.pm index cad4374..437ef98 100644 --- a/videosite/Base.pm +++ b/videosite/Base.pm @@ -1,74 +1,67 @@ # (c) 2007 by Ralf Ertzinger # 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; } @@ -76,32 +69,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->_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"; @@ -111,6 +97,30 @@ sub getconfstr { 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"; @@ -122,19 +132,139 @@ sub gethelpstr { } $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;