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