# (c) 2007 by Ralf Ertzinger <ralf@camperquake.de>
# licensed under GNU GPL v2

package videosite::Base;

use strict;
use LWP::UserAgent;
use HTTP::Cookies;
use Data::Dumper;

sub new {
    my $class = shift;
    my $self = {'_CONNECTOR' => undef,
                _API => {
                    io => sub { print(@_) },
                    io_debug => sub { print(@_) },
                    connectors => sub { return ({ 'name' => 'direct',
                                                  'schemas' => {} }) },
                },
                @_,
               };

    # Add the 'enabled' property to all modules
    $self->{_PARAMS}->{enabled} = [1, 'Whether the module is enabled'];
    bless($self, $class);

    return $self;
}

sub error {
    my $self = shift;
    my @data = @_;

    $data[0] = "(" . ref($self) . ") " . $data[0];

    $self->{_API}->{io}->(@data);
}

sub debug {
    my $self = shift;
    my @data = @_;

    $data[0] = "("  . ref($self) . ") " . $data[0];

    $self->{_API}->{io_debug}->(@data);
}

sub _getval {
    my $self = shift;
    my $key = shift;
    my $path = ['plugin', $self->{NAME}, $key];
    my $val;

    # Try to read from the global config
    # Fall back to default
    if ($self->{_API}->{config_has}->($path)) {
        $val = $self->{_API}->{config_get}->($path);
    } elsif (exists($self->{_PARAMS}->{$key})) {
        $val = $self->{_PARAMS}->{$key}->[0];
    } else {
        $self->error('Requested unknown config key %s', $key);
    }

    $self->debug('Returning %s=%s', $key, $val);
    return $val;
}

sub setval {
    my $self = shift;
    my $key = shift;
    my $val = shift;
    my $path = ['plugin', $self->{NAME}, $key];

    if (exists($self->{'_PARAMS'}->{$key})) {
        $self->{_API}->{config_set}->($path, $val);
    } else {
        $self->error('Module does not have a parameter named %s', $self->$key);
    }
}

sub getconfstr {
    my $self = shift;
    my $s = 'Options for ' . $self->{'NAME'} . ":\n";
    my $k;
    my $p;

    foreach $k (keys(%{$self->{'_PARAMS'}})) {
        $p = $self->_getval($k);
        $s .= sprintf("  %s: %s", $k, $p);
        if ($p eq $self->{'_PARAMS'}->{$k}->[0]) {
            $s .= " (default)\n";
        } else {
            $s .= "\n";
        }
    }

    return $s;
}

# Return a list of the parameters supported by the module
# Does not return the 'enabled' parameter
sub getparamlist {
    my $self = shift;
    my $word = shift;

    return grep {$_ ne 'enabled' && /^$word/} keys %{$self->{'_PARAMS'}};
}

# Return a list of valid parameter values, if the parameter has
# such a list.
sub getparamvalues {
    my $self = shift;
    my $param = shift;
    my $word = shift;

    unless(exists($self->{'_PARAMS'}->{$param}->[2])) {
        return ();
    } else {
        return grep {/^$word/} keys %{$self->{'_PARAMS'}->{$param}->[2]};
    }
}


sub gethelpstr {
    my $self = shift;
    my $s = 'Help for ' . $self->{'NAME'} . ":\n";
    my $k;
    my $p;

    if (exists($self->{'DESC'})) {
        $s .= "Description:\n " . $self->{'DESC'};
    }

    $s .= " Options:\n";
    foreach $k (keys(%{$self->{'_PARAMS'}})) {
        $p = $self->{'_PARAMS'}->{$k}->[0];
        if (exists($self->{'_PARAMS'}->{$k}->[2])) {
            # The parameter has a list of allowed values. Add the keys and their help
            $s .= sprintf("  %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
            foreach (sort keys(%{$self->{'_PARAMS'}->{$k}->[2]})) {
                $s .= sprintf("     %s: %s\n", $_, $self->{'_PARAMS'}->{$k}->[2]->{$_});
            }
        } else {
            # The parameter just has a default value and a help text
            $s .= sprintf("  %s: %s (default: %s)\n", $k, $self->{'_PARAMS'}->{$k}->[1], $p);
        }
    }

    return $s;
}

sub ua {
    my $self = shift;
    my $ua;

    $ua = LWP::UserAgent->new(
            'agent' => 'Mozilla/5.0',
            'cookie_jar' => HTTP::Cookies->new,
            'parse_head' => 0,
            'timeout' => 15,
            );

    # Remove a currently defined HTTPS proxy. See below for a longer explanation.
    delete($ENV{'HTTPS_PROXY'});

    if (defined($self->{'_CONNECTOR'})) {
        #
        # The "environment" connector is special, it loads proxies from
        # the environment variables. It also does not define any schemas,
        # so the code below will not reset this.
        #
        if ($self->{'_CONNECTOR'}->{'name'} eq 'environment') {
            $self->debug("Using proxy settings from environment");
            $ua->env_proxy;
        }
        my $schemas = $self->{'_CONNECTOR'}->{'schemas'};
        foreach (keys(%{$schemas})) {
            $self->debug("Adding schema %s with proxy %s", $_, $schemas->{$_});
            if ($_ eq 'https') {
                # OK, so here's the gist.
                #
                # The usual way of reqesting an HTTPS URL through a proxy is
                # to connect to the proxy server, issue a CONNECT request to
                # create a channel to the web server and start an SSL session over
                # this channel, so there is an end-to-end connection between
                # the client and the server.
                #
                # Setting a proxy for the https schema in LWP WILL NOT ACCOMPLISH
                # THIS.
                #
                # LWP will connect to the proxy server, and issue a standard GET
                # request for the target URL, which most proxy servers will refuse
                # to get.
                #
                # The way to use a proxy server is to set some environment variables
                # and let the underlying Crypt::SSLeay module do the rest.
                #
                # This is positively appaling.
                $ENV{'HTTPS_PROXY'} = $schemas->{$_};
            } else {
                $ua->proxy($_, $schemas->{$_});
            }
        }
    }

    $self->{_CACHED_UA} = $ua;

    return $ua;
}

sub _cached_ua {
    my $self = shift;

    return $self->{_CACHED_UA};
}

sub simple_get {
    my $self = shift;
    my $url = shift;
    my $ua = shift || $self->ua();
    my $r;

    $self->debug("Getting %s", $url);
    $r = $ua->get($url);
    $self->debug("Return code: %s", $r->status_line);
    $self->debug("Content length: %d", length($r->decoded_content)) if $r->is_success();
    return $r->decoded_content() if $r->is_success();
    return undef;
}

sub decode_hexurl {
    my $self = shift;
    my $d = shift;

    $d =~ s/%([[:xdigit:]]{2})/chr(hex($1))/ge;

    return $d;
}

sub decode_querystring {
    my $self = shift;

    return { map { split /=/, $_, 2; } split /&/, shift };
}

sub connectors {
    my $self = shift;

    return $self->{_API}->{connectors}->();
}

sub selectconn {
    my $self = shift;

    $self->{'_CONNECTOR'} = shift;
}

#
# This function was used in previous versions of videosite. If it's called
# we are dealing with an old plugin which probably needs some minor modifications
# to work properly.
#
# Generate a warning message.
#
sub _prepare_parameters {
    my $self = shift;

    $self->error("THIS MODULE IS CALLING _prepare_parameters(). THIS FUNCTION IS DEPRECATED. See readme.txt in the plugin directory.");
}

#
# Register a callbacks into the core API to the plugin.
# Example of those are config getter/setters and IO functions
# The API is a hash reference containing subroutine references.
#
sub register_api {
    my $self = shift;
    my $api = shift;

    $self->{_API} = $api;
}

1;