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