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