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