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