videosite/Base.pm

   1 # (c) 2007 by Ralf Ertzinger <ralf@camperquake.de>
   2 # licensed under GNU GPL v2
   3
   4 package videosite::Base;
   5
   6 use strict;
   7 use LWP::UserAgent;
   8 use HTTP::Cookies;
   9 use Data::Dumper;
  10
  11 sub new {
  12     my $class = shift;
  13     my $self = {'_CONNECTOR' => undef,
  14                 _API => {
  15                     io => sub { print(@_) },
  16                     io_debug => sub { print(@_) },
  17                     connectors => sub { return ({ 'name' => 'direct',
  18                                                   'schemas' => {} }) },
  19                 },
  20                 @_,
  21                };
  22
  23     # Add the 'enabled' property to all modules
  24     $self->{_PARAMS}->{enabled} = [1, 'Whether the module is enabled'];
  25     bless($self, $class);
  26
  27     return $self;
  28 }
  29
  30 sub error {
  31     my $self = shift;
  32     my @data = @_;
  33
  34     $data[0] = "(" . ref($self) . ") " . $data[0];
  35
  36     $self->{_API}->{io}->(@data);
  37 }
  38
  39 sub debug {
  40     my $self = shift;
  41     my @data = @_;
  42
  43     $data[0] = "("  . ref($self) . ") " . $data[0];
  44
  45     $self->{_API}->{io_debug}->(@data);
  46 }
  47
  48 sub _getval {
  49     my $self = shift;
  50     my $key = shift;
  51     my $path = ['plugin', $self->{NAME}, $key];
  52     my $val;
  53
  54     # Try to read from the global config
  55     # Fall back to default
  56     if ($self->{_API}->{config_has}->($path)) {
  57         $val = $self->{_API}->{config_get}->($path);
  58     } elsif (exists($self->{_PARAMS}->{$key})) {
  59         $val = $self->{_PARAMS}->{$key}->[0];
  60     } else {
  61         $self->error('Requested unknown config key %s', $key);
  62     }
  63
  64     $self->debug('Returning %s=%s', $key, $val);
  65     return $val;
  66 }
  67
  68 sub setval {
  69     my $self = shift;
  70     my $key = shift;
  71     my $val = shift;
  72     my $path = ['plugin', $self->{NAME}, $key];
  73
  74     if (exists($self->{'_PARAMS'}->{$key})) {
  75         $self->{_API}->{config_set}->($path, $val);
  76     } else {
  77         $self->error('Module does not have a parameter named %s', $self->$key);
  78     }
  79 }
  80
  81 sub getconfstr {
  82     my $self = shift;
  83     my $s = 'Options for ' . $self->{'NAME'} . ":\n";
  84     my $k;
  85     my $p;
  86
  87     foreach $k (keys(%{$self->{'_PARAMS'}})) {
  88         $p = $self->_getval($k);
  89         $s .= sprintf("  %s: %s", $k, $p);
  90         if ($p eq $self->{'_PARAMS'}->{$k}->[0]) {
  91             $s .= " (default)\n";
  92         } else {
  93             $s .= "\n";
  94         }
  95     }
  96
  97     return $s;
  98 }
  99
 100 # Return a list of the parameters supported by the module
 101 # Does not return the 'enabled' parameter
 102 sub getparamlist {
 103     my $self = shift;
 104     my $word = shift;
 105
 106     return grep {$_ ne 'enabled' && /^$word/} keys %{$self->{'_PARAMS'}};
 107 }
 108
 109 # Return a list of valid parameter values, if the parameter has
 110 # such a list.
 111 sub getparamvalues {
 112     my $self = shift;
 113     my $param = shift;
 114     my $word = shift;
 115
 116     unless(exists($self->{'_PARAMS'}->{$param}->[2])) {
 117         return ();
 118     } else {
 119         return grep {/^$word/} keys %{$self->{'_PARAMS'}->{$param}->[2]};
 120     }
 121 }
 122
 123
 124 sub gethelpstr {
 125     my $self = shift;
 126     my $s = 'Help for ' . $self->{'NAME'} . ":\n";
 127     my $k;
 128     my $p;
 129
 130     if (exists($self->{'DESC'})) {
 131         $s .= "Description:\n " . $self->{'DESC'};
 132     }
 133
 134     $s .= " Options:\n";
 135     foreach $k (keys(%{$self->{'_PARAMS'}})) {
 136         $p = $self->{'_PARAMS'}->{$k}->[0];
 137         if (exists($self->{'_PARAMS'}->{$k}->[2])) {
 138             # The parameter has a list of allowed values. Add the keys and their help
 139             $s .= sprintf("  %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
 140             foreach (sort keys(%{$self->{'_PARAMS'}->{$k}->[2]})) {
 141                 $s .= sprintf("     %s: %s\n", $_, $self->{'_PARAMS'}->{$k}->[2]->{$_});
 142             }
 143         } else {
 144             # The parameter just has a default value and a help text
 145             $s .= sprintf("  %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
 146         }
 147     }
 148
 149     return $s;
 150 }
 151
 152 sub ua {
 153     my $self = shift;
 154     my $ua;
 155
 156     $ua = LWP::UserAgent->new(
 157             'agent' => 'Mozilla/5.0',
 158             'cookie_jar' => HTTP::Cookies->new,
 159             'timeout' => 15,
 160             );
 161
 162     # Remove a currently defined HTTPS proxy. See below for a longer explanation.
 163     delete($ENV{'HTTPS_PROXY'});
 164
 165     if (defined($self->{'_CONNECTOR'})) {
 166         my $schemas = $self->{'_CONNECTOR'}->{'schemas'};
 167         foreach (keys(%{$schemas})) {
 168             $self->debug("Adding schema %s with proxy %s", $_, $schemas->{$_});
 169             if ($_ eq 'https') {
 170                 # OK, so here's the gist.
 171                 #
 172                 # The usual way of reqesting an HTTPS URL through a proxy is
 173                 # to connect to the proxy server, issue a CONNECT request to
 174                 # create a channel to the web server and start an SSL session over
 175                 # this channel, so there is an end-to-end connection between
 176                 # the client and the server.
 177                 #
 178                 # Setting a proxy for the https schema in LWP WILL NOT ACCOMPLISH
 179                 # THIS.
 180                 #
 181                 # LWP will connect to the proxy server, and issue a standard GET
 182                 # request for the target URL, which most proxy servers will refuse
 183                 # to get.
 184                 #
 185                 # The way to use a proxy server is to set some environment variables
 186                 # and let the underlying Crypt::SSLeay module do the rest.
 187                 #
 188                 # This is positively appaling.
 189                 $ENV{'HTTPS_PROXY'} = $schemas->{$_};
 190             } else {
 191                 $ua->proxy($_, $schemas->{$_});
 192             }
 193         }
 194     }
 195
 196     $self->{_CACHED_UA} = $ua;
 197
 198     return $ua;
 199 }
 200
 201 sub _cached_ua {
 202     my $self = shift;
 203
 204     return $self->{_CACHED_UA};
 205 }
 206
 207 sub simple_get {
 208     my $self = shift;
 209     my $url = shift;
 210     my $ua = shift || $self->ua();
 211     my $r;
 212
 213     $r = $ua->get($url);
 214     return $r->decoded_content() if $r->is_success();
 215     return undef;
 216 }
 217
 218 sub decode_hexurl {
 219     my $self = shift;
 220     my $d = shift;
 221
 222     $d =~ s/%([[:xdigit:]]{2})/chr(hex($1))/ge;
 223
 224     return $d;
 225 }
 226
 227 sub decode_querystring {
 228     my $self = shift;
 229
 230     return { map { split /=/, $_, 2; } split /&/, shift };
 231 }
 232
 233 sub connectors {
 234     my $self = shift;
 235
 236     return $self->{_API}->{connectors}->();
 237 }
 238
 239 sub selectconn {
 240     my $self = shift;
 241
 242     $self->{'_CONNECTOR'} = shift;
 243 }
 244
 245 #
 246 # This function was used in previous versions of videosite. If it's called
 247 # we are dealing with an old plugin which probably needs some minor modifications
 248 # to work properly.
 249 #
 250 # Generate a warning message.
 251 #
 252 sub _prepare_parameters {
 253     my $self = shift;
 254
 255     $self->error("THIS MODULE IS CALLING _prepare_parameters(). THIS FUNCTION IS DEPRECATED. See readme.txt in the plugin directory.");
 256 }
 257
 258 #
 259 # Register a callbacks into the core API to the plugin.
 260 # Example of those are config getter/setters and IO functions
 261 # The API is a hash reference containing subroutine references.
 262 #
 263 sub register_api {
 264     my $self = shift;
 265     my $api = shift;
 266
 267     $self->{_API} = $api;
 268 }
 269
 270 1;