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