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