1171 lines
45 KiB
Perl
1171 lines
45 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Plugins
|
|
# Author : Alex Krohn
|
|
# CVS Info :
|
|
# $Id: Manager.pm,v 1.61 2005/04/14 07:43:09 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.61 $ =~ /(\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 ) = @$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 } );
|
|
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> " : "<a href='$url'>$i</a> ";
|
|
}
|
|
}
|
|
$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"> $plugin<br>
|
|
~;
|
|
foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) {
|
|
next if (defined $menu_option->[2] and ! $menu_option->[2]);
|
|
$menu .= qq~ </font><font face="Tahoma,Arial,Helvetica" size="2"> <a href="$menu_option->[1]">$menu_option->[0]</a><br>~;
|
|
}
|
|
$menu .= " ";
|
|
}
|
|
if ($menu) {
|
|
$menu = qq~
|
|
<tr>
|
|
<td bgcolor="#DDDDDD"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="2">Installed
|
|
Plugins </font></td>
|
|
</tr>
|
|
$menu
|
|
~;
|
|
}
|
|
return $menu;
|
|
}
|
|
|
|
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;
|
|
|