# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Plugins
#   Author  : Alex Krohn
#   CVS Info : 087,071,086,086,085      
#   $Id: Manager.pm,v 1.63 2006/10/18 23:59:36 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: A web based admin to manage installed and uninstalled
# plugins.
#

package GT::Plugins::Manager;
# ==================================================================
use strict;
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/;
use GT::Base;
use GT::Plugins;
use GT::Tar;

$ERROR_MESSAGE = 'GT::Plugins';
$DEBUG   = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.63 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
    cfg            => undef,
    cgi            => undef,
    tpl_root       => '.',
    tpl_prefix     => '',
    prefix         => '',
    plugin_dir     => undef,
    plugin         => undef,
    plugin_name    => undef,
    tar            => undef,
    prog_ver       => undef,
    prog_reg       => undef,
    prog_name      => undef,
    # The program init (e.g. admin) path; if set, this is passed to the plugin
    # server and also changes the way download_gossamer() returns errors:
    prog_init      => undef,
    prog_user_cgi  => undef,
    prog_admin_cgi => undef,
    prog_images    => undef,
    prog_libs      => undef,
    base_url       => undef,
    func_url       => undef,
    path_to_perl   => undef,
    perl_args      => undef
};
@ISA = qw/GT::Base/;

sub init {
# ----------------------------------------------------------------
# Load the plugin config file on init() called from GT::Base.
#
    my $self  = shift;
    my $param = $self->common_param(@_);
    $self->set($param);

    if (!$self->{plugin_dir} or !-d $self->{plugin_dir}) {
        return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager.");
    }
    $self->{cfg} = GT::Plugins->load_cfg($self->{plugin_dir});
}

sub process {
# ----------------------------------------------------------------
# Determines what to do based on cgi input, and return a hash
# content => data for printing by outside application.
#
    my $self = shift;
    ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to manager");
    defined $self->{plugin_dir} and -d $self->{plugin_dir}     or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager");

# Figure out what to do.
    my $action = $self->{cgi}->param('plugin_man_do') || '';
    my $vars   = {};
    my $page   = 'plugin_manager_list.html';

    CASE: {
        ($action eq 'pre_install')      and do {
            $vars = $self->pre_install;
            $page = 'plugin_manager_pre_install.html';
            last CASE;
        };
        ($action eq 'install')          and do {
            $vars = $self->install;
            last CASE;
        };
        ($action eq 'pre_uninstall')    and do {
            $vars = $self->pre_uninstall;
            $page = 'plugin_manager_pre_uninstall.html';
            last CASE;
        };
        ($action eq 'uninstall')        and do {
            $vars = $self->uninstall;
            last CASE;
        };
        ($action eq 'pre_delete')       and do {
            $page = 'plugin_manager_delete.html';
            last CASE;
        };
        ($action eq 'delete')           and do {
            $vars = $self->delete;
            last CASE;
        };
        ($action eq 'hooks')            and do {
            $vars = $self->set_hooks;
            $page = 'plugin_manager_hooks.html';
            last CASE;
        };
        ($action eq 'edit_installed')   and do {
            $vars = $self->edit_installed;
            $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit.html';
            last CASE;
        };
        ($action eq 'edit_uninstalled') and do {
            $vars = $self->edit_uninstalled;
            $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit_files.html';
            last CASE;
        };
        ($action eq 'download')         and do {
            $page = 'plugin_manager_download.html';
            last CASE;
        };
        ($action eq 'download_gossamer') and do {
            $page = 'plugin_manager_download.html';
            $vars = $self->download_gossamer;
            last CASE;
        };
        ($action eq 'download_url')     and do {
            $vars = $self->download_url;
            last CASE;
        };
        ($action eq 'download_file')    and do {
            $vars = $self->download_file;
            last CASE;
        };
    };
    if ($page eq 'plugin_manager_list.html') {
        $vars->{installed}   = $self->installed_plugins_html;
        $vars->{uninstalled} = $self->uninstalled_plugins_html;
    }

    return $self->page($page, $vars);
}

sub page {
# ----------------------------------------------------------------
# Returns a content => parsed_page hash ref.
#
    my ($self, $page, $vars) = @_;
    my $cgi     = $self->{cgi}->get_hash;
    foreach my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; }
    my $contents = GT::Template->parse(
        $self->{tpl_prefix} . $page,
        $vars,
        { root => $self->{tpl_root} }
    ) or return;
    return { content => \$contents };
}

# ------------------------------------------------------------------------------------------------- #
# Installing/Uninstalling Plugins                                                                   #
# ------------------------------------------------------------------------------------------------- #

sub pre_install {
# ----------------------------------------------------------------
# Display pre-installation message.
#
    my $self = shift;
    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' };
    my $tar         = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => $GT::Plugins::error };
    my $plugin      = $self->_load_plugin_install($tar, $plugin_name) or return { error => $GT::Plugins::error };
    my $plugin_pkg = $self->{prefix} . $plugin_name;
    $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;
    my $pre_code;
    {
        no strict 'refs';
        $pre_code = ${$plugin_pkg . '::'}{'pre_install'};
    }
    my $message  = 'No pre installation message supplied.';
    if (defined $pre_code and defined &{$pre_code}) {
        local ($@, $SIG{__DIE__}, $^W);
        eval {
            $message = $pre_code->();
        };
        if ($@) {
            $message = "Error running installation code: $@";
        }
        if (! defined $message) {
            no strict 'refs';
            $message  = ${$plugin_pkg . "::error"} || "No error message provided.";
        }
    }

# Check for overwriting.
    my $install_to  = $self->{plugin_dir} . "/" . $plugin_name . ".pm";
    if (-e $install_to) {
        my $old_plugin  = $self->installed_plugin_info($plugin_name);
        my $old_version = $old_plugin ? $old_plugin->{version} : "(Can't load installed: $GT::Plugins::error)";
        my $new_plugin  = $self->uninstalled_plugin_info($plugin_name);
        my $new_version = $new_plugin ? $new_plugin->{version} : "(Can't load uninstalled: $GT::Plugins::error)";

        return { instructions => $message, old_version => $old_version, new_version => $new_version, confirm => 1 };
    }
    else {
        return { instructions => $message };
    }
}

sub install {
# ----------------------------------------------------------------
# Install the plugin.
#
    my $self = shift;

    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" };
    my $skip_inst   = $self->{cgi}->param('skip_install');

    my $tar         = $self->_open_tar($plugin_name, 'Uninstalled') or return;
    my $plugin      = $self->_load_plugin_install($tar, $plugin_name) or return;
    my $install_to  = $self->{plugin_dir} . "/" . $plugin_name . ".pm";

# Get the main code, and save it.
    my $plugin_code = $tar->get_file("$plugin_name.pm") or return { error => "Unable to locate the $plugin_name.pm file in tar" };

# Save the code.
    open (FILE, "> $install_to") or return { error => "Unable to create plugin file: $install_to. Reason: $!" };
    print FILE $plugin_code->body_as_string;
    close FILE;

# Add the plugin to the config.
    delete $self->{cfg}->{$plugin_name};

    $self->{cfg}->{$plugin_name}->{meta} = $plugin->{meta};
    $self->{cfg}->{$plugin_name}->{version} = $plugin->{version};
    GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});

# Run the install code if requested.
    my ($message, $error);

    my $plugin_pkg = $self->{prefix} . $plugin_name;
    $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;
    my $code;
    {
        no strict 'refs';
        $code = ${$plugin_pkg . "::"}{install};
    }
    if ($self->{cgi}->param('skip_install')) {
        $message = "Installation code skipped.";
    }
    elsif (defined $code and defined &{$code}) {
        require GT::Plugins::Installer;
        my $args;
        foreach my $attrib (keys %$ATTRIBS) {
            $args->{$attrib} = $self->{$attrib};
        }
        my $installer = new GT::Plugins::Installer($args);
        local ($@, $SIG{__DIE__}, $^W);
        eval {
            $message = $code->($installer, $tar);
        };
# Oh, oh, didn't install properly.
        if ($@) {
            delete $self->{cfg}->{$plugin_name};
            GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
            unlink $install_to;
            return { error => "Error running installation code: $@" };
        }
        if (! defined $message) {
            delete $self->{cfg}->{$plugin_name};
            GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
            unlink $install_to;
            no strict 'refs';
            $error   = ${$plugin_pkg . "::error"};
            $message = $error || "No error message provided. ($@)";
            return { error => "Unable to install plugin: '$message'" };
        }
    }
    else {
        $message = "No installation code found.";
    }

# Move the tar file to the Installed directory.
    my $move_from = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar";
    my $move_to   = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar";
    $tar->close_tar;  # Need to close the tar file.

    rename($move_from, $move_to) or return { error => "Unable to move plugin from $move_from => $move_to ($!)" };

# Installed ok, return results.
    if ($error) {
        return { error => $error, reload => 1 };
    }
    else {
        my $output = qq~
<p><font face='Tahoma,Arial,Helvetica' size=2 color=green><b>Plugin $plugin_name Installed</b></font><br>
<font face='Tahoma,Arial,Helvetica' size=2 color="black">The plugin has been successfully installed.<br><br>
<b>Installation Notes:</b><br>
$message
</font></p>
        ~;
        return { results => $output, reload => 1 };
    }
}

sub pre_uninstall {
# ----------------------------------------------------------------
# Display pre-uninstallation message.
#
    my $self = shift;
    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' };
    my $tar         = $self->_open_tar($plugin_name, 'Installed') or return;
    my $plugin      = $self->_load_plugin_install($tar, $plugin_name) or return;
    my $plugin_pkg = $self->{prefix} . $plugin_name;
    $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;
    my $post_code;
    {
        no strict 'refs';
        $post_code = ${$plugin_pkg . '::'}{'pre_uninstall'};
    }
    my $message = 'No pre uninstallation message supplied.';
    if (defined $post_code and defined &{$post_code}) {
        local ($@, $SIG{__DIE__}, $^W);
        eval {
            $message = $post_code->();
        };
        if ($@) {
            $message = "Error running uninstallation code: $@";
        }
        if (! defined $message) {
            no strict 'refs';
            my $error = ${$plugin_pkg . "::error"};
            $message  = $error || "No error message provided.";
        }
    }
    return { instructions => $message };
}

sub uninstall {
# ----------------------------------------------------------------
# Display uninstallation message.
#
    my $self = shift;

    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" };
    my $skip_uninst = $self->{cgi}->param('skip_uninstall');
    my $remove_from = $self->{plugin_dir} . "/" . $plugin_name . ".pm";
    my $tar         = $self->_open_tar($plugin_name, 'Installed');
    my $move_from   = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar";
    my $move_to     = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar";
    my $plugin_pkg = $self->{prefix} . $plugin_name;
    $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;

    if (! $tar) {
        delete $self->{cfg}->{$plugin_name};
        GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
        unlink($remove_from);
        return { error => "Unable to load tar file: $GT::Plugins::error" };
    }
    my $plugin      = $self->_load_plugin_install($tar, $plugin_name);
    if (! $plugin) {
        delete $self->{cfg}->{$plugin_name};
        GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
        $tar->close_tar;
        unlink($remove_from);
        rename($move_from, $move_to);
        return { error => "Unable to load uninstall file: $GT::Plugins::error" };
    }

# Run any uninstallation code.
    my ($code, $output, $error);
    {
        no strict 'refs';
        $code = ${$plugin_pkg . "::"}{uninstall};
    }
    if ($self->{cgi}->param('skip_uninstall')) {
        $output = "Uninstall code skipped.";
    }
    elsif (defined $code and defined &{$code}) {
        require GT::Plugins::Installer;
        my $args;
        foreach my $attrib (keys %$ATTRIBS) {
            $args->{$attrib} = $self->{$attrib};
        }
        my $installer = new GT::Plugins::Installer($args);

        local ($@, $SIG{__DIE__}, $^W);
        eval {
            $output = $code->($installer, $tar);
        };
        if ($@) {
            $error = "Error in uninstall code: $@";
        }
        if (! $output and ! $error) {
            $output = "Uninstall completed.";
        }
    }
    else {
        $output = "No uninstall code found.";
    }

# Remove the plugin from the config.
    delete $self->{cfg}->{$plugin_name};
    GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});

# Remove the .pm file.
    unlink($remove_from) or return { error => "Unable to remove tar file: $remove_from. Reason: $!" };

# Move the tar file back to the Uninstalled directory.
    $tar->close_tar;  # Need to close the tar file.
    rename($move_from, $move_to) or return { error => "Unable to place plugin back into Uninstalled directory: $move_from => $move_to ($!)" };

    return { results => $output, reload => 1, error => $error };
}

# ------------------------------------------------------------------------------------------------- #
# Editing Plugins                                                                                   #
# ------------------------------------------------------------------------------------------------- #

sub edit_installed {
# ----------------------------------------------------------------
# Edit a requested plugin.
#
    my $self = shift;
    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" };
    if (! exists $self->{cfg}->{$plugin_name}) {
        return { error => "Invalid plugin name: $plugin_name" };
    }

# Update the plugin if requested.
    my ($results, $reload);
    if ($self->{cgi}->param('edit')) {
        my %enabled_hooks = map { $_ => 1 } $self->{cgi}->param('hooks');
        my %enabled_menu  = map { $_ => 1 } $self->{cgi}->param('menu');
        if (ref $self->{cfg}->{$plugin_name}->{hooks} eq 'ARRAY') {
            my $i = 0;
            foreach my $hook (@{$self->{cfg}->{$plugin_name}->{hooks}}) {
                $hook->[3] = exists $enabled_hooks{$i++} ? 1 : 0;
            }
        }
        if (ref $self->{cfg}->{$plugin_name}->{menu} eq 'ARRAY') {
            my $i = 0;
            foreach my $menu (@{$self->{cfg}->{$plugin_name}->{menu}}) {
                $menu->[2] = exists $enabled_menu{$i++} ? 1 : 0;
            }
        }
        if (ref $self->{cfg}->{$plugin_name}->{user} eq 'ARRAY') {

            my %opts;
            foreach my $option ( @{$self->{cfg}->{$plugin_name}->{user} || []} ) {
                $opts{$option->[0]} = $option;
            }

            foreach my $key ($self->{cgi}->param()) {
                next if ($key !~ /^user-(.+)/);
                my $real_key = $1;
                my @values   = $self->{cgi}->param($key);
# find out if the item is a checkbox, if it is, make sure that it's an arrayref
                my $val      = (uc($opts{$real_key}->[3]) eq 'CHECKBOX') ? [@values] : $values[0];
                foreach my $opt (@{$self->{cfg}->{$plugin_name}->{user}}) {
                    if ($opt->[0] eq $real_key) {
                        $opt->[1] = $val;
                    }
                }
            }
        }
        GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
        $results = "Plugin updated successfully.";
        $reload = 1;
    }
    my $plugin = $self->{cfg}->{$plugin_name};
    my $hooks  = $self->load_hooks($plugin_name);
    my $menu   = $self->load_menu($plugin_name);
    my $opts   = $self->load_options($plugin_name);

    return { hooks => $hooks, menu => $menu, options => $opts, %{$plugin->{meta}}, results => $results, reload => $reload };
}

sub edit_uninstalled {
# ----------------------------------------------------------------
# Edit a requested plugin.
#
    my $self = shift;
    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" };
    my $tar         = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => "Unable to open tar file: $GT::Plugins::error" };
    my $base        = $self->{base_url};
    my ($output, $results, $body, $body_name);

    my $error   = '';
    my $delete = $self->{cgi}->param('delete');
    if ($delete) {
        $tar->remove_file($delete);
        $tar->write ? ($results = "File $delete has been successfully removed!") : ($error = "Unable to delete file: $GT::Tar::error");
    }
    my $add = $self->{cgi}->param('add');
    if ($add) {
        my $body = $self->{cgi}->param('filebody');
        $tar->add_data(name => $add, body => $body);
        $tar->write ? ($results = "File $add successfully added.") : ($error = "Unable to add file: $GT::Tar::error");
    }
    my $edit = $self->{cgi}->param('edit');
    if ($edit) {
        my $file = $tar->get_file($edit);
        if ($file) {
            $body = $file->body_as_string;
            $body = $self->{cgi}->html_escape($body);
            $body_name = $file->name;
        }
    }
    my $save = $self->{cgi}->param('save');
    if ($save) {
        my $file = $tar->get_file($save);
        if ($file) {
            my $body = $self->{cgi}->param('body');
            $body =~ s/\r//g;
            $file->body($body);
            $tar->write ? ($results = "File $save updated successfully.") : ($error = "Unable to save file: $GT::Tar::error");
        }
    }
    my $perl = $self->{cgi}->param('perl');
    if ($perl) {
        my $file = $tar->get_file($perl);
        if ($file) {
            $results = $self->_syntax_check($file);
        }
    }
    my $files       = $tar->files;

    foreach my $file (@$files) {
        my $name = $file->name;
        next if ($name eq 'Wizard.pm');
        my $size = length $file->body_as_string;

        $output .= qq~
<tr><td><font face='Tahoma,Arial,Helvetica' size=2>$name ($size bytes)</font></td>
    <td><font face='Tahoma,Arial,Helvetica' size=2>
            <a href="$base&plugin_man_do=edit_uninstalled&edit=$name&plugin_name=$plugin_name">Edit</a> |
            <a href="$base&plugin_man_do=edit_uninstalled&perl=$name&plugin_name=$plugin_name">Perl Check</a>
        ~;
        $output .= qq~
            | <a href="$base&plugin_man_do=edit_uninstalled&delete=$name&plugin_name=$plugin_name">Delete</a>
        ~ if (($name ne 'Install.pm') and ($name ne $plugin_name . '.pm'));
        $output .= qq~
        </font>
    </td></tr>
        ~;
    }
    my $plugin  = $self->_load_plugin_install($tar, $plugin_name) or ($error = "Unable to load install file: $GT::Plugins::error");
    $plugin->{meta} ||= {};
    $plugin->{meta}->{title}        ||= $plugin_name;
    $plugin->{meta}->{author}       ||= 'Unknown';
    $plugin->{meta}->{url}          ||= '';
    $plugin->{meta}->{description}  ||= '';
    $plugin->{version}              ||= 'Unknown';
    return { files => $output, %{$plugin->{meta}}, results => $results, body => $body, body_name => $body_name, inst_error => $error };
}

sub load_menu {
# -----------------------------------------------------------------
# Returns the html to enable/disable admin menu options.
#
    my ($self, $plugin) = @_;
    return unless (ref $self->{cfg}->{$plugin}->{menu} eq 'ARRAY');
    my $output = qq~
<tr><td bgcolor="#DDDDDD" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Menu Options (show/hide)</font></td></tr>
    ~;
    my $i = 0;
    foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) {
        my ($menu, $url, $enabled) = @$menu_option;
        defined $enabled or ($enabled = 1);
        $enabled = $enabled ? ' CHECKED' : '';
        $output .= qq~
<tr><td colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="checkbox" name="menu" value="$i"$enabled> $menu</font></td></tr>
        ~;
        $i++;
    }
    return $output;
}

sub load_hooks {
# -----------------------------------------------------------------
# Returns the html to enable/disable hooks.
#
    my ($self, $plugin) = @_;
    return unless (ref $self->{cfg}->{$plugin}->{hooks} eq 'ARRAY');
    my $output = qq~
<tr><td bgcolor="#DDDDDD" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Plugin Hooks (enable/disable)</font></td></tr>
    ~;
    my $i = 0;

    foreach my $hook (@{$self->{cfg}->{$plugin}->{hooks}}) {
        my ($hookname, $prepost, $action, $enabled) = @$hook;
        defined $enabled or ($enabled = 1);
        $enabled = $enabled ? ' CHECKED' : '';
        $output .= qq~
<tr><td colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="checkbox" name="hooks" value="$i"$enabled> $hookname ($prepost)</font></td></tr>
        ~;
        $i++;
    }
    return $output;
}

sub load_options {
# -----------------------------------------------------------------
# Returns the html to enable/disable plugin options.
#
    my ($self, $plugin) = @_;
    return unless (ref $self->{cfg}->{$plugin}->{user} eq 'ARRAY');
    my $output = qq~
<tr><td bgcolor="#DDDDDD" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Plugin Options</font></td></tr>
    ~;

    # This may be changed in the future
    require GT::SQL::Display::HTML;
    my $HTML = GT::SQL::Display::HTML->new();
    foreach my $option (@{$self->{cfg}->{$plugin}->{user}}) {
        my ($name, $val, $ins, $type, $names, $values, $form_size) = @$option;

        $type ||= 'text'; $type = lc( $type );
        my $options = {};
        foreach my $i ( 0 .. $#$names ) { $options->{ $values->[$i] } = $names->[$i]; }

        no strict 'refs';
        my $form_element = $HTML->$type( { name => "user-$name", value => $val, values => $options, def => { form_size => $form_size } } );
        use strict;

        if ($ins) {
            $output .= qq~<tr><td colspan=2><font face="Tahoma,Arial,Helvetica" size="2">$ins</font></td></tr>~;
        }

        $output .= qq~
<tr>
    <td><font face="Tahoma,Arial,Helvetica" size="2">$name</font></td>
    <td><font face="Tahoma,Arial,Helvetica" size="2">$form_element</font></td>
</tr>
        ~;

#        if ($ins) {
#            $output .= qq~<tr><td colspan=2><font face="Tahoma,Arial,Helvetica" size="2">$ins</font></td></tr>~;
#        }
#
#        $output .= qq~
#<tr>
#    <td><font face="Tahoma,Arial,Helvetica" size="2">$name</font></td>
#    <td><font face="Tahoma,Arial,Helvetica" size="2"><input type="text" name="user-$name" value="$val"></font></td>
#</tr>
#        ~;
    }

    return $output;
}

# ------------------------------------------------------------------------------------------------- #
# Removing Files                                                                                    #
# ------------------------------------------------------------------------------------------------- #

sub delete {
# ----------------------------------------------------------------
# Remove a plugin completely from the Uninstalled dir.
#
    my $self = shift;
    my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" };
    my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar";
    return unlink($file) ? { results => "Plugin successfully removed." } : { error => "Unable to remove plugin: $file. Reason: $!" };
}

# ------------------------------------------------------------------------------------------------- #
# Downloading Plugins                                                                               #
# ------------------------------------------------------------------------------------------------- #

sub download_gossamer {
    my $self = shift;

    require GT::WWW;
    require GT::Date;

    my $reg_number = $self->{prog_reg};
    my $url = "http://www.gossamer-threads.com/perl/updates/plugin.cgi";
    my $mh  = 10;
    my $nh  = $self->{cgi}->param('nh') || 1;
    my $beg = $nh == 1 ? 0 : $mh * ($nh - 1);
    my $www = GT::WWW->new(
        protocol => 'http',
        host => 'www.gossamer-threads.com',
        path => '/perl/updates/plugin.cgi',
        parameters => [
            product         => $self->{prog_name},
            product_version => $self->{prog_ver},
            reg_number      => $reg_number,
            sb              => $self->{cgi}->param('sb') || 'plugin_name',
            so              => $self->{cgi}->param('so') || 'asc',
            $self->{prog_init} ? (init_path => $self->{prog_init}) : (),
        ]
    );
    my $page = $www->get or return { error => "Unable to contact Gossamer Threads: " . $www->error() . ".  Please try again later." };
    my @plugins     = split /\n/, $page;
    my $status_line = shift @plugins;
    my ($status)    = $status_line =~ /^# Status: (\w+)$/;

    if ($status ne 'ok') {
        if (!$self->{prog_init}) {
            # Old products - they only expect a single error tag containing the error message
            return { error => "You are not authorized to connect to the plugin server. Please contact support\@gossamer-threads.com for more information and reference status: '$status'." };
        }
        else {
            # New programs just get the error_code and format their own message in the template.
            # Error codes:
            # admin_path_mismatch_reset - the stored admin path does not match; it can be reset from the license area
            # admin_path_mismatch - the stored admin path does not match; no resets are available
            # invalid_product_id - the 'product' provided is unknown by the plugin server
            return { error_code => $status };
        }
    }

    my $plugin_cfg =  do "$self->{plugin_dir}/plugin.cfg" || {};
    my $count      = 0;
    my $hits       = $#plugins + 1;
    my (@output, $speedbar, $html);

    my $font    = 'font face="Tahoma,Arial,Helvetica" size="2"';
    my $output  = qq~
        <table border=1 cellpadding=0 cellspacing=0><tr><td>
        <table border=0 width=600>
        <tr>
        <td valign=top><b><$font>Plugin Name</b></font></td>
        <td valign=top><b><$font>Latest Version</b></font></td>
        <td valign=top><b><$font>Action</b></font></td>
        </tr>
    ~;
    foreach my $p (@plugins) {
        $count++;
        next if $nh > 1 and $count < $beg + 1;

        my %row;
        ($row{plg_id}, $row{plg_name}, $row{plg_version}, $row{plg_url}, $row{plg_support}, $row{plg_support_url}, $row{plg_language}, $row{plg_updated}, $row{plg_license}, $row{plg_price}, $row{plg_author}, $row{cli_id_fk}, $row{author_name}, $row{plg_description}) = split /\t/, $p;
        $row{plg_updated} = GT::Date::date_get($row{plg_updated}, "%ddd%, %mmm% %dd% %yyyy% %hh%:%MM%:%ss%") if $row{plg_updated};

        my $fetch = "$url/$row{plg_name}.tar?id=$row{plg_id};reg_number=$reg_number";
        $row{download_url} = $self->{cgi}->escape($fetch);
        $row{installed}    = $plugin_cfg->{$row{plg_name}} ? $plugin_cfg->{$row{plg_name}}->{version} : '';
        push @output, \%row;

        my $price = $row{plg_license} == 2 ? $row{plg_price} : 'Free';
        $output .= qq~
            <tr>
            <td valign=top>
                <$font><b>$row{plg_name}</b><br>
                Author: $row{author_name}<br>
                Last Updated: $row{plg_updated}<br>
                Description: <br>$row{plg_description}<br>
                Price: $price
                </font>
            </td>
            <td valign=top><$font>$row{plg_version}</font></td>
            <td valign=top><$font><a href="$self->{base_url}&plugin_man_do=download_url&url=$row{download_url}">Download</a></font></td>
            </tr>
        ~;
        last if @output == $mh;
    }
    if ($hits > $mh) {
        my $pages = int($hits / $mh);
        $pages++ if $hits % $mh;
        for my $i (1..$pages) {
            $self->{cgi}->param('nh', $i);
            my $url = $self->{cgi}->url;
            $speedbar .= $i == $nh ? "<b>$i</b>&nbsp;" : "<a href='$url'>$i</a>&nbsp;";
        }
    }
    $output = qq~
        <p><$font>There are <b>$hits</b> plugins available for download.</font></p>
        $speedbar
        $output
        </table>
        </td></tr></table>
        $speedbar
    ~;
    return { plugins => \@output, num_plugins => $hits, speedbar => $speedbar, base_url => $self->{base_url}, gossamer => $output };
}

sub download_file {
# -------------------------------------------------------------------
# Place the upload file into the Uninstalled directory.
#
    my $self = shift;
    my $file = $self->{cgi}->param('file');
    if (! $file) {
        return { error => "Please press browse to pick a file before uploading." };
    }
    my ($name) = $file =~ m,([^/\\]+)$,;
    if ($name !~ /^[\w\-\.]+\.tar$/) {
        return { error => "Invalid file name: $name. Must be a .tar file, and only be letters and numbers, no spaces." };
    }
    my $full_path = $self->{plugin_dir} . "/Uninstalled/" . $name;
    open (FILE, "> $full_path") or return { error => "Unable to create file: $full_path ($!)" };
    binmode FILE;       # Output stream
    binmode $file;      # Input stream
    my ($read, $buffer);
    while ($read = read($file, $buffer, 4096)) {
        print FILE $buffer;
    }
    close FILE;

    return { results => "File was uploaded successfully." };
}

sub download_url {
# -------------------------------------------------------------------
# Fetch a plugin from a URL and save it to the folder.
#
    my $self = shift;
    my $url = $self->{cgi}->param('url');
    $url or return { error => "Please enter a valid url." };
    require GT::WWW;
    my ($protocol) = GT::WWW->parse_url($url);
    return { error => "Invalid URL specified" } unless $protocol;

    unless (GT::WWW->protocol_supported($protocol)) {
        return { error => "Unsupported protocol entered: $protocol" };
    }

    my ($fh, $plugin_file, $full_path, $plugin_error, $status_error, $open_error, $no_filename, $print_error);
    my $www = GT::WWW->new($url);
    $www->chunk_size(16 * 1024); # Get 16KB at a time
    $www->chunk(sub {
        my $chunk = shift;
        unless ($fh or defined $plugin_error) {
            my $response = $www->response;
            my $status = $response->status;
            my $header = $response->header;
            if ($status_error = not $status) {
                $www->cancel;
                return;
            }
            if ($header->contains('X-Plugins' => 'Error')) {
                $plugin_error = '';
            }
            else {
                $plugin_file = {$header->header_words('Content-Disposition')}->{filename};
                unless ($plugin_file) {
                    if (!$www->query_string) {
                        my $path = $www->path;
                        ($plugin_file) = $path =~ m{/([^/]+)\.tar$};
                        $plugin_file .= ".tar" if $plugin_file;
                    }
                    unless ($plugin_file) {
                        $open_error = "No plugin found at url: $url";
                        $no_filename = 1;
                        $www->cancel;
                        return;
                    }
                }
                $fh = \do { local *PLUGIN; *PLUGIN };
                $full_path = "$self->{plugin_dir}/Uninstalled/$plugin_file";
                unless (open $fh, "> $full_path") {
                    $open_error = "Unable to create file '$full_path': $!";
                    $www->cancel;
                    return;
                }
                binmode $fh;
            }
        }
        if (defined $plugin_error) { $plugin_error .= $$chunk }
        else {
            unless (print $fh $$chunk) {
                $print_error = "Unable to continue writing to file '$full_path': $!. Removing partial file.";
                $www->cancel;
                unlink $full_path;
            }
        }
    });

    my $response = $www->get or return { error => "Unable to retrieve plugin: " . $www->error };
    $status_error and return { error => "Unable to retrieve plugin: Server returned error status: " . (int $response->status) . $response->status };
    defined $plugin_error and return { error => $plugin_error };
    $open_error and return { error => $open_error };
    $print_error and return { error => $print_error };

    return { results => "Plugin $plugin_file retrieved successfully." };
}

# ------------------------------------------------------------------------------------------------- #
# Utilities                                                                                         #
# ------------------------------------------------------------------------------------------------- #

sub admin_menu {
# ----------------------------------------------------------------
# Displays the admin menu.
#
    my $self = shift;
    my $menu = '';
    foreach my $plugin (sort keys %{$self->{cfg}}) {
        next unless ($self->{cfg}->{$plugin}->{menu});
        $menu .= qq~
  <tr>
    <td><font face="Tahoma,Arial,Helvetica" size="2">&nbsp;$plugin<br>
        ~;
        foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) {
            next if (defined $menu_option->[2] and ! $menu_option->[2]);
            $menu .= qq~&nbsp;&nbsp;</font><font face="Tahoma,Arial,Helvetica" size="2"> <a href="$menu_option->[1]">$menu_option->[0]</a><br>~;
        }
        $menu .= "&nbsp;";
    }
    if ($menu) {
        $menu = qq~
  <tr>
    <td bgcolor="#DDDDDD"><font face="Tahoma,Arial,Helvetica" size="2">&nbsp;</font><font face="Tahoma,Arial,Helvetica" size="2">Installed
      Plugins </font></td>
  </tr>
  $menu
        ~;
    }
    return $menu;
}

sub admin_menu_items {
# -----------------------------------------------------------------------------
# Returns tags meant for a template to reproduce the above menu.  In
# particular, you get a 'plugin_menus' loop which has a 'plugin_name' key and
# 'plugin_menu' loop; plugin_menu contains two keys - name and url.
#
    my $self = shift;
    my @plugins;
    for my $plugin (sort keys %{$self->{cfg}}) {
        next unless $self->{cfg}->{$plugin}->{menu};
        push @plugins, { plugin_name => $plugin };
        for my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) {
            next if defined $menu_option->[2] and not $menu_option->[2];
            push @{$plugins[-1]->{plugin_menu}}, { name => $menu_option->[0], url => $menu_option->[1] };
        }
    }
    return { plugin_menus => \@plugins };
}

sub installed_plugins {
# ----------------------------------------------------------------
# Returns a list of installed plugins, not formatted.
#
    my $self = shift;
    my $plgs = {};
    foreach my $plugin (keys %{$self->{cfg}}) {
        next if (substr($plugin, 0, 1) eq '_');
        $plgs->{$plugin} = $self->{cfg}->{$plugin};
    }
    return $plgs;
}

sub installed_plugins_html {
# ----------------------------------------------------------------
# Returns a formatted string of installed plugins.
#
    my $self = shift;
    my $plugins  = $self->installed_plugins;
    my $count   = 0;
    my $font    = 'font face="Tahoma,Arial,Helvetica" size="2"';
    my $html    = qq~
            <table border=1 cellpadding=0 cellspacing=0><tr><td><table border=0 width=550>
                <tr>
                    <td colspan=4><$font><b>Installed Plugins</b></font></td>
                </tr>
                <tr>
                    <td><$font>Name</font></td>
                    <td><$font>Version</font></td>
                    <td><$font>Author</font></td>
                    <td><$font>Action</font></td>
                </tr>
            ~;
# Show installed plugins.
    my $base     = $self->{base_url};
    foreach my $name (sort keys %$plugins) {
        my $plugin  = $plugins->{$name};
        my $plugin_e= $self->{cgi}->escape($name);
        my $title   = $plugin->{meta}->{title}      || $name;
        my $author  = $plugin->{meta}->{author}     || 'Unknown Author';
        my $url     = $plugin->{meta}->{url}        || '';
        my $version = $plugin->{version}            || 'Unknown Version';
        $url and ($author = qq~<a href="$url" target="_blank">$author</a>~);
        $html .= qq~
            <tr>
                <td><$font>$title</font></td>
                <td><$font><b>$version</b></font></td>
                <td><$font>$author</font></td>
                <td><$font><a href="$base&plugin_man_do=edit_installed&plugin_name=$plugin_e">Edit</a> |
                           <a href="$base&plugin_man_do=pre_uninstall&plugin_name=$plugin_e">Uninstall</a></font></td>
            </tr>
        ~;
        $count++;
    }
    $html .= "</table></td></tr></table>";
    if (! $count) {
        $html = "<table border=1 cellpadding=0 cellspacing=0><tr><td><table border=0 width=550><tr><td>No plugins have been installed.</td></tr></table></td></tr></table>";
    }
    return $html;
}

sub uninstalled_plugins {
# ----------------------------------------------------------------
# Returns a list of uninstalled plugins, not formatted.
#
    my $self = shift;
    my $dir  = $self->{plugin_dir} . '/Uninstalled';
    my %plugins;
    opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
    while (defined(my $file = readdir(DIR))) {
        next unless ($file =~ /^(.+)\.tar$/);
        my $plugin_name = $1;
        my $tar    = $self->_open_tar($plugin_name, 'Uninstalled');
        $tar    or $plugins{$plugin_name} = { tar_error => $GT::Plugins::error } and next;
        my $plugin = $self->_load_plugin_install($tar, $plugin_name);
        $plugin or $plugins{$plugin_name} = { inst_error => $GT::Plugins::error } and next;
        $plugins{$plugin_name} = $plugin;
    }
    closedir(DIR);
    return \%plugins;
}

sub uninstalled_plugins_html {
# ----------------------------------------------------------------
# Returns a formatted string of uninstalled plugins.
#
    my $self = shift;
    my $plugins = $self->uninstalled_plugins;
    my $count   = 0;
    my $font    = 'font face="Tahoma,Arial,Helvetica" size="2"';
    my $html    = qq~
            <table border=1 cellpadding=0 cellspacing=0><tr><td><table border=0 width=550>
                <tr>
                    <td colspan=4><$font><b>Uninstalled Plugins</b></font></td>
                </tr>
                <tr>
                    <td><$font>Name</font></td>
                    <td><$font>Version</font></td>
                    <td><$font>Author</font></td>
                    <td><$font>Action</font></td>
                </tr>
            ~;
    my $base = $self->{base_url};
    my $func = $self->{func_url} ? $self->{func_url} : "$base&do=plugin";
    foreach my $name (sort keys %$plugins) {
        my $plugin  = $plugins->{$name};
        my $plugin_e= $self->{cgi}->escape($name);
        my $title   = $plugin->{meta}->{title}      || $name;
        my $author  = $plugin->{meta}->{author}     || 'Unknown Author';
        my $url     = $plugin->{meta}->{url}        || '';
        my $version = $plugin->{version}            || 'Unknown Version';
        my $tar_err = $plugin->{tar_error}          || '';
        my $inst_err = $plugin->{inst_error}        || '';
        my $inst_l  = qq~<a href="$base&plugin_man_do=pre_install&plugin_name=$plugin_e">Install</a> |~;
        my $edit_l  = qq~<a href="$base&plugin_man_do=edit_uninstalled&plugin_name=$plugin_e">Edit</a> |~;
        my $error   = '';
        if ($tar_err) {
            $error  = "<br><font color='red' size=1>$tar_err</font>";
            $inst_l = '';
            $edit_l = '';
        }
        if ($inst_err) {
            $error  = "<br><font color='red' size=1>$inst_err</font>";
            $inst_l = '';
        }
        $url and ($author = qq~<a href="$url" target="_blank">$author</a>~);
        $html .= qq~
            <tr>
                <td><$font>$title$error</font></td>
                <td><$font><b>$version</b></font></td>
                <td><$font>$author</font></td>
                    <td><$font>$inst_l $edit_l
                               <a href="$base&plugin_man_do=pre_delete&plugin_name=$plugin_e">Delete</a>
                               | <a href="$func&plugin=$plugin_e&download=1">Download</a></font></td>
            </tr>
        ~;
        $count++;
    }
    $html .= "</table></td></tr></table>";
    if (! $count) {
        $html = "<table border=1 cellpadding=0 cellspacing=0><tr><td><table border=0 width=550><tr><td>No plugins are available to be installed.</td></tr></table></td></tr></table>";
    }
    return $html;
}

sub uninstalled_plugin_info {
# ----------------------------------------------------------------
# Returns a hash of plugin info for an uninstalled plugin.
#
    my ($self, $plugin_name) = @_;
    my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar";
    if (! -e $file) {
        return $self->error('CANTOPEN', 'WARN', $file, $!);
    }
    my $tar    = GT::Tar->open($file) or return;
    my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return;
    return $plugin;
}

sub installed_plugin_info {
# ----------------------------------------------------------------
# Return a hash of plugin info for an installed plugin.
#
    my ($self, $plugin_name) = @_;
    return exists $self->{cfg}->{$plugin_name} ?
                            $self->{cfg}->{$plugin_name} :
                            $self->error('NOPLUGIN', 'WARN', $plugin_name);
}

sub _open_tar {
# ----------------------------------------------------------------
# Opens a tar file.
#
    my ($self, $plugin_name, $dir) = @_;
    my $file = $self->{plugin_dir} . '/' . $dir . '/' . $plugin_name . '.tar';
    if (! -e $file) {
        return $self->error('CANTLOAD', 'WARN', $file, $!);
    }
    my $tar  = GT::Tar->open( $file ) or return $self->error('CANTLOAD', 'WARN', $file, "Unable to parse tar file: $GT::Tar::error");
    return $tar;
}

sub _load_plugin_install {
# ----------------------------------------------------------------
# Takes a .tar file, looks for an Install.pm file, evals it, and
# returns a hash of meta info.
#
    my ($self, $tar, $plugin_name) = @_;
    my $install = $tar->get_file('Install.pm') or return $self->error('CANTLOAD', 'WARN', $plugin_name, "No Install.pm file found in tar!");

# Eval the install file.
    my $file = $install->body_as_string;
    {
        local ($@, $SIG{__DIE__}, $^W);
        eval "$file";
        if ($@) {
            return $self->error('CANTLOAD', 'WARN', $plugin_name, "Install.pm does not compile: $@");
        }
    }

# Load the meta info.
    no strict 'refs';
    my $plugin_pkg = $self->{prefix} . $plugin_name;
    $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;

    my $version = ${$plugin_pkg . "::VERSION"};

    my $meta    = defined ${$plugin_pkg . '::META'}    ? ${$plugin_pkg . '::META'}    : {};
    if (! defined $version) {
        $version = defined $meta->{version} ? $meta->{version} : 'UNKNOWN';
    }
    my $author  = defined $meta->{author}       ? $meta->{author}       : 'Unknown';
    my $url     = defined $meta->{url}          ? $meta->{url}          : 'Unknown';
    my $desc    = defined $meta->{description}  ? $meta->{description}  : 'None';

    return { name => $plugin_name, meta => $meta, author => $author, url => $url, description => $desc, version => $version };
}

sub _syntax_check {
# -------------------------------------------------------------------
# Returns the output of syntax checking the current file.
#
    my $self = shift;
    my $file = shift;
    my $results;

    require GT::TempFile;
    if ($self->{path_to_perl} and -x $self->{path_to_perl}) {
        my $tmp_file = new GT::TempFile;
        open (TMPFILE, "> $$tmp_file") or return "Couldn't open temp file: $$tmp_file ($!)";
        print TMPFILE $file->body_as_string;
        close TMPFILE;

        my $args         = $self->{perl_args} || '';

# We are not really running under mod_perl in the spawned perl check.
# DBI will not load if it thinks we are (but aren't).
        local($ENV{GATEWAY_INTERFACE}, $ENV{MOD_PERL});
        my $perl_results = `$self->{path_to_perl} $args $$tmp_file 2>&1`;
        my $filename     = $file->name;
        $perl_results    =~ s/$$tmp_file/$filename/g;

        $results = "Perl Said: <br><pre><font color='black' size=3>$perl_results</font></pre>";
    }
    else {
        $results = "Unable to execute perl: $self->{path_to_perl}";
    }
    return $results;
}

1;

