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