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             'parse_head' => 0,
 160             'timeout' => 15,
 161             );
 162
 163     # Remove a currently defined HTTPS proxy. See below for a longer explanation.
 164     delete($ENV{'HTTPS_PROXY'});
 165
 166     if (defined($self->{'_CONNECTOR'})) {
 167         #
 168         # The "environment" connector is special, it loads proxies from
 169         # the environment variables. It also does not define any schemas,
 170         # so the code below will not reset this.
 171         #
 172         if ($self->{'_CONNECTOR'}->{'name'} eq 'environment') {
 173             $self->debug("Using proxy settings from environment");
 174             $ua->env_proxy;
 175         }
 176         my $schemas = $self->{'_CONNECTOR'}->{'schemas'};
 177         foreach (keys(%{$schemas})) {
 178             $self->debug("Adding schema %s with proxy %s", $_, $schemas->{$_});
 179             if ($_ eq 'https') {
 180                 # OK, so here's the gist.
 181                 #
 182                 # The usual way of reqesting an HTTPS URL through a proxy is
 183                 # to connect to the proxy server, issue a CONNECT request to
 184                 # create a channel to the web server and start an SSL session over
 185                 # this channel, so there is an end-to-end connection between
 186                 # the client and the server.
 187                 #
 188                 # Setting a proxy for the https schema in LWP WILL NOT ACCOMPLISH
 189                 # THIS.
 190                 #
 191                 # LWP will connect to the proxy server, and issue a standard GET
 192                 # request for the target URL, which most proxy servers will refuse
 193                 # to get.
 194                 #
 195                 # The way to use a proxy server is to set some environment variables
 196                 # and let the underlying Crypt::SSLeay module do the rest.
 197                 #
 198                 # This is positively appaling.
 199                 $ENV{'HTTPS_PROXY'} = $schemas->{$_};
 200             } else {
 201                 $ua->proxy($_, $schemas->{$_});
 202             }
 203         }
 204     }
 205
 206     $self->{_CACHED_UA} = $ua;
 207
 208     return $ua;
 209 }
 210
 211 sub _cached_ua {
 212     my $self = shift;
 213
 214     return $self->{_CACHED_UA};
 215 }
 216
 217 sub simple_get {
 218     my $self = shift;
 219     my $url = shift;
 220     my $ua = shift || $self->ua();
 221     my $r;
 222
 223     $self->debug("Getting %s", $url);
 224     $r = $ua->get($url);
 225     $self->debug("Return code: %s", $r->status_line);
 226     $self->debug("Content length: %d", length($r->decoded_content)) if $r->is_success();
 227     return $r->decoded_content() if $r->is_success();
 228     return undef;
 229 }
 230
 231 sub decode_hexurl {
 232     my $self = shift;
 233     my $d = shift;
 234
 235     $d =~ s/%([[:xdigit:]]{2})/chr(hex($1))/ge;
 236
 237     return $d;
 238 }
 239
 240 sub decode_querystring {
 241     my $self = shift;
 242
 243     return { map { split /=/, $_, 2; } split /&/, shift };
 244 }
 245
 246 sub connectors {
 247     my $self = shift;
 248
 249     return $self->{_API}->{connectors}->();
 250 }
 251
 252 sub selectconn {
 253     my $self = shift;
 254
 255     $self->{'_CONNECTOR'} = shift;
 256 }
 257
 258 #
 259 # This function was used in previous versions of videosite. If it's called
 260 # we are dealing with an old plugin which probably needs some minor modifications
 261 # to work properly.
 262 #
 263 # Generate a warning message.
 264 #
 265 sub _prepare_parameters {
 266     my $self = shift;
 267
 268     $self->error("THIS MODULE IS CALLING _prepare_parameters(). THIS FUNCTION IS DEPRECATED. See readme.txt in the plugin directory.");
 269 }
 270
 271 #
 272 # Register a callbacks into the core API to the plugin.
 273 # Example of those are config getter/setters and IO functions
 274 # The API is a hash reference containing subroutine references.
 275 #
 276 sub register_api {
 277     my $self = shift;
 278     my $api = shift;
 279
 280     $self->{_API} = $api;
 281 }
 282
 283 1;