1099 lines
37 KiB
Perl
1099 lines
37 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Plugins
|
|
# Author : Alex Krohn
|
|
# CVS Info :
|
|
# $Id: Wizard.pm,v 1.34 2005/04/14 07:43:48 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description: A web based admin to install/uninstall/edit plugins.
|
|
#
|
|
|
|
package GT::Plugins::Wizard;
|
|
# ==================================================================
|
|
use strict;
|
|
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/;
|
|
use GT::Base;
|
|
use GT::Plugins;
|
|
use GT::Tar;
|
|
use GT::Dumper;
|
|
|
|
$ERROR_MESSAGE = 'GT::Plugins';
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
|
|
$ATTRIBS = {
|
|
prefix => '',
|
|
cgi => undef,
|
|
initial_indent => ' ',
|
|
tpl_root => '.',
|
|
tpl_prefix => '',
|
|
plugin_dir => undef,
|
|
plugin => undef,
|
|
tar => undef,
|
|
prog_ver => undef,
|
|
install_header => undef,
|
|
dirs => {},
|
|
oo => undef
|
|
};
|
|
@ISA = qw/GT::Base/;
|
|
|
|
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 wizard");
|
|
defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to wizard");
|
|
|
|
# Figure out what to do.
|
|
my $action = $self->{cgi}->param('plugin_wiz_do') || '';
|
|
my $vars = {};
|
|
my $page = 'plugin_wizard_step1.html';
|
|
my $plugin = $self->{cgi}->param('plugin_name');
|
|
$self->load_plugin($plugin) if ($plugin);
|
|
|
|
CASE: {
|
|
# Meta Information
|
|
($action eq 'step2') and do {
|
|
$vars = $self->_validate_step1();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step1.html'; last CASE }
|
|
$vars = $self->_load_step2();
|
|
$page = 'plugin_wizard_step2.html';
|
|
last CASE;
|
|
};
|
|
# Plugin Hooks
|
|
($action eq 'step3') and do {
|
|
$vars = $self->_validate_step2() unless ($self->{cgi}->param('skip_validate'));
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step2.html'; last CASE }
|
|
$vars = $self->_load_step3();
|
|
$page = 'plugin_wizard_step3.html';
|
|
last CASE;
|
|
};
|
|
# Admin Menu Options.
|
|
($action eq 'step4') and do {
|
|
$vars = $self->_validate_step3();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step3.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step3.html'; last CASE }
|
|
$vars = $self->_load_step4();
|
|
$page = 'plugin_wizard_step4.html';
|
|
last CASE;
|
|
};
|
|
# User Options.
|
|
($action eq 'step5') and do {
|
|
$vars = $self->_validate_step4();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step4.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step4.html'; last CASE }
|
|
$vars = $self->_load_step5();
|
|
$page = 'plugin_wizard_step5.html';
|
|
last CASE;
|
|
};
|
|
# Included Files.
|
|
($action eq 'step6') and do {
|
|
$vars = $self->_validate_step5();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step5.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step5.html'; last CASE }
|
|
$vars = $self->_load_step6();
|
|
$page = 'plugin_wizard_step6.html';
|
|
last CASE;
|
|
};
|
|
# All Done.
|
|
($action eq 'step7') and do {
|
|
$vars = $self->_validate_step6();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step6.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step6.html'; last CASE }
|
|
$vars = $self->_load_step7();
|
|
$page = 'plugin_wizard_step7.html';
|
|
last CASE;
|
|
};
|
|
# Create the plugin and finish.
|
|
($action eq 'create') and do {
|
|
$vars = $self->_validate_step7();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
$vars = $self->_create_install();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
$vars = $self->_create_code();
|
|
if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE }
|
|
$page = 'plugin_wizard_step8.html';
|
|
last CASE;
|
|
};
|
|
|
|
# Get a list of plugins that can be edited.
|
|
$vars->{edit} = $self->_list_editable;
|
|
}
|
|
|
|
return $self->page($page, $vars);
|
|
}
|
|
|
|
sub page {
|
|
# ----------------------------------------------------------------
|
|
# Returns a content => parsed_page hash ref.
|
|
#
|
|
my ($self, $page, $vars) = @_;
|
|
my $cgi = $self->{cgi}->get_hash;
|
|
for 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 };
|
|
}
|
|
|
|
sub load_plugin {
|
|
# ----------------------------------------------------------------
|
|
# Loads a plugin.
|
|
#
|
|
my ($self, $plugin_name) = @_;
|
|
$self->{plugin}->{name} = $plugin_name;
|
|
return unless (defined $plugin_name and $plugin_name =~ /^\w{2,20}$/);
|
|
|
|
$self->{tar} = $self->_load_tar;
|
|
$self->_load_plugin;
|
|
return 1;
|
|
}
|
|
|
|
sub save_plugin {
|
|
# -------------------------------------------------------------------
|
|
# Saves the plugin back to disk.
|
|
#
|
|
my $self = shift;
|
|
my $wizard = $self->{tar}->get_file('Wizard.pm');
|
|
if (! $wizard) {
|
|
$self->{tar}->add_data(name => 'Wizard.pm', body => $self->_create_wizard);
|
|
}
|
|
else {
|
|
$wizard->body($self->_create_wizard);
|
|
}
|
|
return $self->{tar}->write;
|
|
}
|
|
|
|
sub _get_hook_params {
|
|
# ------------------------------------------------------------------------------
|
|
my $hook = shift;
|
|
my $param = shift;
|
|
my %results;
|
|
for my $e (@$hook) {
|
|
my $val = ref $e->{$param} ? join(", ", @{$e->{$param}}) : $e->{$param};
|
|
$results{$val}++;
|
|
}
|
|
return sort keys %results;
|
|
}
|
|
|
|
sub _validate_step1 {
|
|
# -------------------------------------------------------------------
|
|
# Checks that the plugin name is valid.
|
|
#
|
|
my $self = shift;
|
|
my $name = $self->{cgi}->param('plugin_name');
|
|
$name or return { error => "Please enter a valid plugin name." };
|
|
$name =~ /^\w{2,20}$/ or return {
|
|
error => "Plugin names must be only letters and numbers, and be between 2 and 20 characters."
|
|
};
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
return { plugin_name => $name };
|
|
}
|
|
|
|
sub _load_step2 {
|
|
# -------------------------------------------------------------------
|
|
# Preloads vars for meta information.
|
|
#
|
|
my $self = shift;
|
|
return defined $self->{plugin}->{meta}->{prog_ver}
|
|
? $self->{plugin}->{meta}
|
|
: { %{$self->{plugin}->{meta}}, prog_ver => $self->{prog_ver} };
|
|
}
|
|
|
|
sub _validate_step2 {
|
|
# -------------------------------------------------------------------
|
|
# Validates the meta information.
|
|
#
|
|
my $self = shift;
|
|
my $version = $self->{cgi}->param('version');
|
|
$version or return { error => "Please make sure you enter a version, perhaps start with 0.0.1 to begin." };
|
|
$version =~ /^[\d\.]+$/ or return { error => "Version numbers should contain only numbers and periods." };
|
|
|
|
my $author = $self->{cgi}->param('author');
|
|
$author or return { error => "Please make sure you enter an author." };
|
|
|
|
my $url = $self->{cgi}->param('url');
|
|
|
|
my $license = $self->{cgi}->param('license');
|
|
$license or return { error => "Please make sure you enter in a license style." };
|
|
|
|
my $prog_ver = $self->{cgi}->param('prog_ver');
|
|
$prog_ver or return {
|
|
error => 'Please enter a program version that your plugin will require. Set to 1 for all versions. ' .
|
|
'This is useful to ensure the plugin user has the required version before using the plugin.'
|
|
};
|
|
|
|
my $description = $self->{cgi}->param('description');
|
|
|
|
$self->{plugin}->{meta} = {
|
|
version => $version,
|
|
author => $author,
|
|
url => $url,
|
|
license => $license,
|
|
description => $description,
|
|
prog_ver => $prog_ver
|
|
};
|
|
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
|
|
return {};
|
|
}
|
|
|
|
sub _load_step3 {
|
|
# -------------------------------------------------------------------
|
|
# Preloads vars for hook information.
|
|
#
|
|
my $self = shift;
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
|
|
# try to load the hook config file
|
|
return { hooks => '' } unless defined $self->{plugin}->{hooks} and @{$self->{plugin}->{hooks}};
|
|
|
|
my $output = qq~
|
|
<table border=1 width="100%" cellpadding=3 bordercolor="#C0C0C0" cellspacing=0><tr>
|
|
<td><b><$font>Hook</font></b></td>
|
|
<td><b><$font>Type</font></b></td>
|
|
<td><b><$font>Code</font></b></td>
|
|
<td><b><$font>Position</font></b></td>
|
|
</tr>~;
|
|
|
|
for my $hook (@{$self->{plugin}->{hooks}}) {
|
|
my $id = join("|", @$hook);
|
|
my ($name, $type, $code, $position) = @$hook;
|
|
$output .= qq~
|
|
<tr>
|
|
<td><$font><input type="checkbox" name="delete" value="$id"> $name</font></td>
|
|
<td><$font>$type</font></td>
|
|
<td><$font>$code</font></td>
|
|
<td><$font>$position</font></td>
|
|
</tr>~;
|
|
}
|
|
$output .= qq~
|
|
</table>
|
|
~;
|
|
return { hooks => $output };
|
|
}
|
|
|
|
sub _validate_step3 {
|
|
# -------------------------------------------------------------------
|
|
# Validate any new hooks that were added.
|
|
#
|
|
my $self = shift;
|
|
$self->{plugin}->{hooks} ||= [];
|
|
|
|
# Remove unwanted hooks.
|
|
my $results = '';
|
|
if ($self->{cgi}->param('delete_btn')) {
|
|
my @to_delete = $self->{cgi}->param('delete');
|
|
for my $del_id (@to_delete) {
|
|
my $i = 0;
|
|
for my $hook (@{$self->{plugin}->{hooks}}) {
|
|
my $id = join("|", @$hook);
|
|
if ($id eq $del_id) {
|
|
$results .= "<li>Plugin hook " . $hook->[0] . " successfully removed.";
|
|
splice @{$self->{plugin}->{hooks}}, $i, 1;
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
}
|
|
# Add new hooks
|
|
my $add_hook = $self->{cgi}->param('name');
|
|
if ($add_hook) {
|
|
my $add_code = $self->{cgi}->param('code');
|
|
my $add_type = $self->{cgi}->param('type');
|
|
my $add_pos = $self->{cgi}->param('pos'); # Not used; future use?
|
|
push @{$self->{plugin}->{hooks}}, [$add_hook, $add_type, $add_code, $add_pos];
|
|
$results .= "<li>Plugin hook $add_hook successfully added.";
|
|
}
|
|
my $hooks = $self->_load_step3;
|
|
if (! $results and $self->{cgi}->param('add_btn')) {
|
|
return { error => "Please fill out the add form completely.", hooks => $hooks->{hooks} };
|
|
}
|
|
if (! $results and $self->{cgi}->param('delete_btn')) {
|
|
return { error => "Please select one or more hooks to delete.", hooks => $hooks->{hooks} };
|
|
}
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
if ($results) {
|
|
return { results => $results, hooks => $hooks->{hooks} };
|
|
}
|
|
return {};
|
|
}
|
|
|
|
sub _load_step4 {
|
|
# -------------------------------------------------------------------
|
|
# Preloads vars for admin menu options.
|
|
#
|
|
my $self = shift;
|
|
return { menu => '' } unless $self->{plugin}->{menu} and @{$self->{plugin}->{menu}};
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
my $output = qq~
|
|
<table border=1 width="100%" cellpadding=3 bordercolor="#C0C0C0" cellspacing=0><tr>
|
|
<td><b><$font>Name</font></b></td>
|
|
<td><b><$font>URL</font></b></td>
|
|
</tr>~;
|
|
|
|
for my $menu (@{$self->{plugin}->{menu}}) {
|
|
my ($name, $url) = @$menu;
|
|
$output .= qq~
|
|
<tr>
|
|
<td><$font><input type="checkbox" name="delete" value="$name"> $name</font></td>
|
|
<td><$font><a href="$url" target="_blank">$url</a></font></td>
|
|
</tr>~;
|
|
}
|
|
$output .= qq~
|
|
</table>
|
|
~;
|
|
return { menu => $output };
|
|
}
|
|
|
|
sub _validate_step4 {
|
|
# -------------------------------------------------------------------
|
|
# Validate any new menu that were added.
|
|
#
|
|
my $self = shift;
|
|
$self->{plugin}->{menu} ||= [];
|
|
|
|
# Remove unwanted menu.
|
|
my $results = '';
|
|
if ($self->{cgi}->param('delete_btn')) {
|
|
my @to_delete = $self->{cgi}->param('delete');
|
|
for my $del_id (@to_delete) {
|
|
my $i = 0;
|
|
for my $menu (@{$self->{plugin}->{menu}}) {
|
|
my ($name, $url) = @$menu;
|
|
if ($name eq $del_id) {
|
|
splice @{$self->{plugin}->{menu}}, $i, 1;
|
|
$results .= "<li>Menu Option " . $name . " successfully removed.";
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Add new menu
|
|
my $add_name = $self->{cgi}->param('name');
|
|
if ($add_name) {
|
|
my $add_url = $self->{cgi}->param('url');
|
|
$self->{plugin}->{menu} ||= [];
|
|
push @{$self->{plugin}->{menu}}, [$add_name, $add_url];
|
|
$results .= "<li>Menu Option $add_name successfully added.";
|
|
}
|
|
|
|
my $menu = $self->_load_step4;
|
|
if (! $results and $self->{cgi}->param('add_btn')) {
|
|
return { error => "Please fill out the add form completely.", menu => $menu->{menu} };
|
|
}
|
|
if (! $results and $self->{cgi}->param('delete_btn')) {
|
|
return { error => "Please select one or more admin menu to delete.", menu => $menu->{menu} };
|
|
}
|
|
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
if ($results) {
|
|
return { results => $results, menu => $menu->{menu} };
|
|
}
|
|
return {};
|
|
}
|
|
|
|
sub _load_step5 {
|
|
# -------------------------------------------------------------------
|
|
# Preloads vars for user options.
|
|
#
|
|
my $self = shift;
|
|
return { user => '' } unless (defined $self->{plugin}->{user} and @{$self->{plugin}->{user}});
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
my $output = qq~
|
|
<table border=1 width="100%" cellpadding=3 bordercolor="#C0C0C0" cellspacing=0><tr>
|
|
<td><b><$font>Name</font></b></td>
|
|
<td><b><$font>Value</font></b></td>
|
|
<td><b><$font>Instructions</font></b></td>
|
|
<td><b><$font>Form Type</font></b></td>
|
|
<td><b><$font>Form Names</font></b></td>
|
|
<td><b><$font>Form Value</font></b></td>
|
|
</tr>~;
|
|
|
|
for my $opt (@{$self->{plugin}->{user}}) {
|
|
my ($name, $val, $instructions, $form_type, $form_names, $form_values ) = @$opt;
|
|
$form_values = @$form_values
|
|
? "<ul>" . join("", map { "<li>" . $self->{cgi}->html_escape($_) . "</li>" } @$form_values) . "</ul>"
|
|
: " ";
|
|
$form_names = @$form_names
|
|
? "<ul>" . join("", map { "<li>" . $self->{cgi}->html_escape($_) . "</li>" } @$form_names) . "</ul>"
|
|
: " ";
|
|
my $ins = $self->{cgi}->html_escape($instructions);
|
|
$val = $self->{cgi}->html_escape($val);
|
|
$output .= qq~
|
|
<tr>
|
|
<td valign="top"><$font><input type="checkbox" name="delete" value="$name"> $name</font></td>
|
|
<td valign="top"><$font>$val</font></td>
|
|
<td valign="top"><$font>$ins </font></td>
|
|
<td valign="top"><$font>$form_type</font></td>
|
|
<td valign="top"><$font>$form_names</font></td>
|
|
<td valign="top"><$font>$form_values</font></td>
|
|
</tr>
|
|
~;
|
|
}
|
|
$output .= qq~</table>~;
|
|
|
|
return { user => $output };
|
|
}
|
|
|
|
sub _validate_step5 {
|
|
# -------------------------------------------------------------------
|
|
# Validate any user options that were added.
|
|
#
|
|
my $self = shift;
|
|
$self->{plugin}->{user} ||= [];
|
|
|
|
# Remove unwanted user options.
|
|
my $results = '';
|
|
if ($self->{cgi}->param('delete_btn')) {
|
|
my @to_delete = $self->{cgi}->param('delete');
|
|
for my $del_id (@to_delete) {
|
|
my $i = 0;
|
|
for my $opt (@{$self->{plugin}->{user}}) {
|
|
my ($name, $val, $ins) = @$opt;
|
|
if ($name eq $del_id) {
|
|
splice @{$self->{plugin}->{user}}, $i, 1;
|
|
$results .= "<li>User Option " . $name . " successfully removed.";
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Add new user option
|
|
my $add_name = $self->{cgi}->param('name');
|
|
if ($add_name) {
|
|
my $add_val = $self->{cgi}->param('value');
|
|
my $add_ins = $self->{cgi}->param('instructions');
|
|
my $form_names = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_names') ];
|
|
my $form_values = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_values') ];
|
|
my $form_type = $self->{cgi}->param('form_type');
|
|
push @{$self->{plugin}->{user}}, [ $add_name, $add_val, $add_ins, $form_type, $form_names, $form_values ];
|
|
$results .= "<li>User Option $add_name successfully added.";
|
|
}
|
|
my $user = $self->_load_step5;
|
|
if (! $results and $self->{cgi}->param('add_btn')) {
|
|
return { error => "Please fill out the add form completely.", user => $user->{user} };
|
|
}
|
|
if (! $results and $self->{cgi}->param('delete_btn')) {
|
|
return { error => "Please select one or more user option to delete.", user => $user->{user} };
|
|
}
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
if ($results) {
|
|
return { results => $results, user => $user->{user} };
|
|
}
|
|
return {};
|
|
}
|
|
|
|
sub _load_step6 {
|
|
# -------------------------------------------------------------------
|
|
# Preloads any user included files.
|
|
#
|
|
my $self = shift;
|
|
return { files => '' } unless (defined $self->{plugin}->{files} and @{$self->{plugin}->{files}});
|
|
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
my $output = qq~
|
|
<table border=1 width="100%" cellpadding=3 bordercolor="#C0C0C0" cellspacing=0><tr>
|
|
<td><b><$font>Filename</font></b></td>
|
|
<td><b><$font>Location</font></b></td>
|
|
</tr>~;
|
|
|
|
my %seen;
|
|
for my $file (@{$self->{plugin}->{files}}) {
|
|
my ($name, $location) = @$file;
|
|
my $id = join("|", @$file);
|
|
next if $name eq "$self->{plugin}->{name}.pm";
|
|
if (exists $self->{dirs}->{$location}) {
|
|
$location = $self->{dirs}->{$location};
|
|
}
|
|
$seen{$name}++;
|
|
$output .= qq~
|
|
<tr>
|
|
<td><$font><input type="checkbox" name="delete" value="$id"> $name</font></td>
|
|
<td><$font>$location</font></td>
|
|
</tr>~;
|
|
}
|
|
my $files = $self->{tar}->files;
|
|
for my $file (@$files) {
|
|
my $name = $file->name;
|
|
my $id = $name . '|';
|
|
|
|
next if $seen{$name} or $name eq 'Wizard.pm' or $name eq 'Install.pm' or $name eq "$self->{plugin}->{name}.pm";
|
|
|
|
push @{$self->{plugin}->{files}}, [$name, ''];
|
|
$output .= qq~
|
|
<tr>
|
|
<td><$font><input type="checkbox" name="delete" value="$id"> $name</font></td>
|
|
<td><$font>Unknown (not added in Wizard)</font></td>
|
|
</tr>~;
|
|
}
|
|
$output .= qq~
|
|
</table>
|
|
~;
|
|
return { files => $output };
|
|
}
|
|
|
|
sub _validate_step6 {
|
|
# -------------------------------------------------------------------
|
|
# Receives files and stores them in the tar file.
|
|
#
|
|
my $self = shift;
|
|
my $results = '';
|
|
$self->{plugin}->{files} ||= [];
|
|
|
|
# Remove any existing files.
|
|
if ($self->{cgi}->param('delete_btn')) {
|
|
my @to_delete = $self->{cgi}->param('delete');
|
|
for my $del_id (@to_delete) {
|
|
my $i = 0;
|
|
for my $file (@{$self->{plugin}->{files}}) {
|
|
my $id = join("|", @$file);
|
|
if ($id eq $del_id) {
|
|
my $name = $file->[0];
|
|
$self->{tar}->remove_file($name);
|
|
$self->{tar}->write;
|
|
splice @{$self->{plugin}->{files}}, $i, 1;
|
|
$results .= "<li>File " . $name . " successfully removed.";
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Add any new attachments.
|
|
my $filename = $self->{cgi}->param('name');
|
|
if ($filename) {
|
|
my $filehandle = $self->{cgi}->param('file');
|
|
my $body = $self->{cgi}->param('add_body');
|
|
my $location = $self->{cgi}->param('location');
|
|
if (ref $filehandle) {
|
|
$body = '';
|
|
my ($buffer, $read);
|
|
while ($read = read($filehandle, $buffer, 4096)) {
|
|
$body .= $buffer;
|
|
}
|
|
}
|
|
$body ||= ' ';
|
|
$body =~ s/\r//g;
|
|
push @{$self->{plugin}->{files}}, [$filename, $location];
|
|
my $res = $self->{tar}->add_data(name => $filename, body => $body);
|
|
$results .= "File $filename attached successfully.";
|
|
}
|
|
my $file = $self->_load_step6;
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
|
|
if (! $results and $self->{cgi}->param('add_btn')) {
|
|
return { error => "Please fill out the add form completely.", files => $file->{files} };
|
|
}
|
|
if (! $results and $self->{cgi}->param('delete_btn')) {
|
|
return { error => "Please select one or more file to delete.", files => $file->{files} };
|
|
}
|
|
if ($results) {
|
|
return { results => $results, files => $file->{files} };
|
|
}
|
|
return {};
|
|
}
|
|
|
|
sub _load_step7 {
|
|
# -------------------------------------------------------------------
|
|
# Fetches the install/uninstall message.
|
|
#
|
|
my $self = shift;
|
|
return {
|
|
install => $self->{plugin}->{install},
|
|
uninstall => $self->{plugin}->{uninstall},
|
|
install_code => $self->{plugin}->{install_code},
|
|
uninstall_code => $self->{plugin}->{uninstall_code}
|
|
};
|
|
}
|
|
|
|
sub _validate_step7 {
|
|
# -------------------------------------------------------------------
|
|
# Saves the install/uninstall message.
|
|
#
|
|
my $self = shift;
|
|
$self->{plugin}->{install} = $self->{cgi}->param('install');
|
|
$self->{plugin}->{uninstall} = $self->{cgi}->param('uninstall');
|
|
$self->{plugin}->{install_code} = $self->{cgi}->param('install_code');
|
|
$self->{plugin}->{uninstall_code} = $self->{cgi}->param('uninstall_code');
|
|
$self->save_plugin or return { error => $GT::Plugins::error };
|
|
return {};
|
|
}
|
|
|
|
sub _create_code {
|
|
# -------------------------------------------------------------------
|
|
# Creates the code file.
|
|
#
|
|
my $self = shift;
|
|
my $output = '';
|
|
my $time = localtime();
|
|
my $version = $self->{plugin}->{meta}->{version} || 0;
|
|
$self->{install_header} ||= '';
|
|
my $stubs = $self->_create_stubs;
|
|
|
|
my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name};
|
|
if (index($plugin_pkg, 'Plugins::') < 0) {
|
|
$plugin_pkg = 'Plugins::' . $plugin_pkg;
|
|
}
|
|
|
|
$output = <<END_OF_PLUGIN;
|
|
# ==================================================================
|
|
# $plugin_pkg - Auto Generated Program Module
|
|
#
|
|
# $plugin_pkg
|
|
# Author : $self->{plugin}->{meta}->{author}
|
|
# Version : $version
|
|
# Updated : $time
|
|
#
|
|
# ==================================================================
|
|
#
|
|
|
|
package $plugin_pkg;
|
|
# ==================================================================
|
|
|
|
$self->{initial_indent}use strict;
|
|
$self->{initial_indent}use GT::Base;
|
|
$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/;
|
|
$self->{initial_indent}$self->{install_header}
|
|
|
|
# Inherit from base class for debug and error methods
|
|
$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base);
|
|
|
|
# Your code begins here.
|
|
$stubs
|
|
|
|
# Always end with a 1.
|
|
1;
|
|
END_OF_PLUGIN
|
|
my $file = $self->{tar}->get_file($self->{plugin}->{name} . '.pm');
|
|
if ($file) {
|
|
my $overwrite = $self->{cgi}->param('overwrite');
|
|
my $skip = $self->{cgi}->param('skip');
|
|
if (! $overwrite and ! $skip) {
|
|
return { error => "Overwrite the existing $self->{plugin}->{name}.pm: <br><input type=submit name=overwrite value='Yes, Overwrite it!'> <input type=submit name=skip value='No, Leave it Alone'>" };
|
|
}
|
|
$file->body($output) if ($overwrite);
|
|
}
|
|
else {
|
|
$self->{tar}->add_data( name => $self->{plugin}->{name} . '.pm', body => $output );
|
|
}
|
|
$self->{tar}->write;
|
|
return {};
|
|
}
|
|
|
|
sub _create_install {
|
|
# -------------------------------------------------------------------
|
|
# Creates the install.pm file.
|
|
#
|
|
my $self = shift;
|
|
my $output = '';
|
|
my $time = localtime();
|
|
my $version = $self->{plugin}->{meta}->{version} || 0;
|
|
(my $qversion = $version) =~ s/(?=['\\])/\\/g;
|
|
|
|
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{plugin}->{meta});
|
|
my $inst_mess = GT::Dumper->dump(var => 'my $inst_msg', data => $self->{plugin}->{install});
|
|
my $uninst_mess = GT::Dumper->dump(var => 'my $uninst_msg', data => $self->{plugin}->{uninstall});
|
|
my $install = $self->_create_install_func;
|
|
my $uninstall = $self->_create_uninstall_func;
|
|
|
|
for ($meta_dump, $inst_mess, $uninst_mess, $install, $uninstall) { s/\r//g }
|
|
|
|
my $inst_code = $self->{plugin}->{install_code} || '';
|
|
$inst_code =~ s/\r//g;
|
|
$inst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here.
|
|
my $uninst_code = $self->{plugin}->{uninstall_code} || '';
|
|
$uninst_code =~ s/\r//g;
|
|
$uninst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here.
|
|
$self->{install_header} ||= '';
|
|
|
|
my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name};
|
|
if (index($plugin_pkg, 'Plugins::') < 0) {
|
|
$plugin_pkg = 'Plugins::' . $plugin_pkg;
|
|
}
|
|
|
|
$output = <<END_OF_PLUGIN;
|
|
# ==================================================================
|
|
# $plugin_pkg - Auto Generated Install Module
|
|
#
|
|
# $plugin_pkg
|
|
# Author : $self->{plugin}->{meta}->{author}
|
|
# Version : $version
|
|
# Updated : $time
|
|
#
|
|
# ==================================================================
|
|
#
|
|
|
|
package $plugin_pkg;
|
|
# ==================================================================
|
|
$self->{initial_indent}use strict;
|
|
$self->{initial_indent}use vars qw/\$VERSION \$DEBUG \$NAME \$META/;
|
|
$self->{initial_indent}use GT::Base;
|
|
$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/;
|
|
$self->{initial_indent}$self->{install_header}
|
|
|
|
$self->{initial_indent}\$VERSION = '$qversion';
|
|
$self->{initial_indent}\$DEBUG = 0;
|
|
$self->{initial_indent}\$NAME = '$self->{plugin}->{name}';
|
|
# Inhert from base class for debug and error methods
|
|
$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base);
|
|
|
|
$self->{initial_indent}$meta_dump
|
|
|
|
sub pre_install {
|
|
# -----------------------------------------------------------------------------
|
|
# This function displays an HTML formatted message that will display any
|
|
# instructions/information to the user before they install the plugin.
|
|
#
|
|
$inst_mess
|
|
return \$inst_msg;
|
|
}
|
|
|
|
sub pre_uninstall {
|
|
# -----------------------------------------------------------------------------
|
|
# This function displays an HTML formatted message that will display any
|
|
# instructions/information to the user before they remove the plugin.
|
|
#
|
|
$uninst_mess
|
|
return \$uninst_msg;
|
|
}
|
|
|
|
sub install {
|
|
# -----------------------------------------------------------------------------
|
|
# This function does the actual installation. Its first argument is a plugin
|
|
# manager which you can use to register hooks, install files, add menu options,
|
|
# etc. The second argument is a GT::Tar object which you can use to access any
|
|
# files in your plugin module.
|
|
#
|
|
# You should return an HTML formatted string that will be displayed to the
|
|
# user.
|
|
#
|
|
# If there is an error, return undef, and set the error message in
|
|
# \$Plugins::$self->{prefix}$self->{plugin}->{name}::error
|
|
#
|
|
my (\$mgr, \$tar) = \@_;
|
|
$install
|
|
$inst_code
|
|
return "The plugin has been successfully installed!";
|
|
}
|
|
|
|
sub uninstall {
|
|
# -----------------------------------------------------------------------------
|
|
# This function removes the plugin. Its first argument is also a plugin
|
|
# manager which you can use to register hooks, install files, add menu options,
|
|
# etc. You should return an HTML formatted string that will be displayed to the
|
|
# user.
|
|
#
|
|
# If there is an error, return undef, and set the error message in
|
|
# \$${plugin_pkg}::error
|
|
#
|
|
my \$mgr = shift;
|
|
$uninstall
|
|
$uninst_code
|
|
return "The plugin has been successfully removed!";
|
|
}
|
|
|
|
1;
|
|
END_OF_PLUGIN
|
|
my $file = $self->{tar}->get_file('Install.pm');
|
|
if ($file) {
|
|
$file->body($output);
|
|
}
|
|
else {
|
|
$self->{tar}->add_data(name => 'Install.pm', body => $output);
|
|
}
|
|
$self->{tar}->write;
|
|
return {};
|
|
}
|
|
|
|
sub _esc {
|
|
# -------------------------------------------------------------------
|
|
$_[0] =~ s/'/\\'/g;
|
|
$_[0] =~ s/\n/\\\n/g;
|
|
$_[0] =~ s/\r//g;
|
|
return;
|
|
}
|
|
|
|
sub _create_install_func {
|
|
# -------------------------------------------------------------------
|
|
# Creates the install function based on everything we know.
|
|
#
|
|
my $self = shift;
|
|
my $code = '';
|
|
for my $hook (@{$self->{plugin}->{hooks}}) {
|
|
my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g;
|
|
my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g;
|
|
my $val4 = $hook->[3];
|
|
|
|
$code .= qq~\n \$mgr->install_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~;
|
|
}
|
|
for my $menu (@{$self->{plugin}->{menu}}) {
|
|
my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g;
|
|
$code .= qq~\n \$mgr->install_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~;
|
|
}
|
|
for my $user (@{$self->{plugin}->{user}}) {
|
|
my $val1 = $user->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $user->[1]; _esc($val2);
|
|
my $val3 = $user->[2]; _esc($val3);
|
|
my $val4 = $user->[3]; _esc($val4);
|
|
require GT::Dumper;
|
|
my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//;
|
|
my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//;
|
|
my $val7 = $user->[6]; _esc($val7);
|
|
$code .= qq~\n \$mgr->install_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~;
|
|
}
|
|
if (@{$self->{plugin}->{files}}) {
|
|
$code .= qq~
|
|
|
|
# Silence warnings
|
|
\$GT::Tar::error ||= '';
|
|
|
|
# The following section will unarchive attached files into the proper location.
|
|
my \$file;~;
|
|
}
|
|
for my $file (@{$self->{plugin}->{files}}) {
|
|
my ($name, $loc) = @$file;
|
|
next if ($name eq $self->{plugin}->{name} . '.pm');
|
|
next if ($name eq 'Install.pm');
|
|
my $path = '';
|
|
if (exists $self->{dirs}->{$loc}) {
|
|
$path = $self->{dirs}->{$loc};
|
|
}
|
|
|
|
my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name};
|
|
if (index($plugin_pkg, 'Plugins::') < 0) {
|
|
$plugin_pkg = 'Plugins::' . $plugin_pkg;
|
|
}
|
|
$code .= qq~
|
|
|
|
# Copying $name to $path directory.
|
|
\$file = \$tar->get_file('$name');
|
|
\$file->name("$path/$name");
|
|
\$file->write or return $plugin_pkg->error("Unable to extract file '$path/$name': \$GT::Tar::error", 'WARN');~;
|
|
}
|
|
return $code;
|
|
}
|
|
|
|
sub _create_uninstall_func {
|
|
# -------------------------------------------------------------------
|
|
# Creates the uninstall function based on everything we know.
|
|
#
|
|
my $self = shift;
|
|
my $code = '';
|
|
for my $hook (@{$self->{plugin}->{hooks}}) {
|
|
my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g;
|
|
my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g;
|
|
my $val4 = $hook->[3];
|
|
$code .= qq~\n \$mgr->uninstall_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~;
|
|
}
|
|
for my $menu (@{$self->{plugin}->{menu}}) {
|
|
my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g;
|
|
$code .= qq~ \$mgr->uninstall_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~;
|
|
}
|
|
for my $user (@{$self->{plugin}->{user}}) {
|
|
my $val1 = $user->[0]; $val1 =~ s/'/\\'/g;
|
|
my $val2 = $user->[1]; _esc($val2);
|
|
my $val3 = $user->[2]; _esc($val3);
|
|
my $val4 = $user->[3]; _esc($val4);
|
|
require GT::Dumper;
|
|
my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//;
|
|
my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//;
|
|
my $val7 = $user->[6]; _esc($val7);
|
|
|
|
$code .= qq~\n \$mgr->uninstall_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~;
|
|
}
|
|
return $code;
|
|
}
|
|
|
|
sub _create_stubs {
|
|
# -------------------------------------------------------------------
|
|
# Creates a subroutine stub for each hook.
|
|
#
|
|
my $self = shift;
|
|
my $code = '';
|
|
if (@{$self->{plugin}->{hooks}}) {
|
|
$code .= qq~
|
|
|
|
# PLUGIN HOOKS
|
|
# ===================================================================
|
|
~;
|
|
}
|
|
my %seen;
|
|
for my $hook (@{$self->{plugin}->{hooks}}) {
|
|
my $full_sub_name = $hook->[2];
|
|
my ($sub_name) = $full_sub_name =~ /([^:]+)$/;
|
|
next if $seen{$sub_name}++;
|
|
my $hook_name = $hook->[0];
|
|
$code .= qq~
|
|
|
|
sub $sub_name {
|
|
# -----------------------------------------------------------------------------
|
|
# This subroutine will be called whenever the hook '$hook_name' is run. You
|
|
# should call @{[$self->{oo} || 'GT::Plugins']}->action(STOP) if you don't want the regular
|
|
# '$hook_name' code to run, otherwise the code will continue as normal.
|
|
#
|
|
my (\@args) = \@_;
|
|
|
|
# Do something useful here
|
|
|
|
return \@args;
|
|
}~;
|
|
}
|
|
if (@{$self->{plugin}->{menu}}) {
|
|
$code .= qq~
|
|
|
|
# ADMIN MENU OPTIONS
|
|
# ===================================================================
|
|
~;
|
|
}
|
|
%seen = ();
|
|
for my $menu (@{$self->{plugin}->{menu}}) {
|
|
my $val1 = $menu->[0];
|
|
my $val2 = $menu->[1];
|
|
my ($func) = $val2 =~ /func=(\w+)/;
|
|
next if $seen{$func}++;
|
|
if ($func) {
|
|
$code .= qq~
|
|
sub $func {
|
|
# -------------------------------------------------------------------
|
|
# This subroutine will be called whenever the user clicks on '$val1' in the
|
|
# admin menu. Remember, you need to print your own HTTP header; to do so you
|
|
# can use:
|
|
#
|
|
# print \$IN->header();
|
|
#
|
|
|
|
}~;
|
|
}
|
|
}
|
|
return $code;
|
|
}
|
|
|
|
sub _create_wizard {
|
|
# -------------------------------------------------------------------
|
|
# Creates the Wizard.pm file which is used to load wizard information.
|
|
#
|
|
my $self = shift;
|
|
my $output = '';
|
|
my $time = localtime();
|
|
my $author = $self->{plugin}->{meta}->{author} || '';
|
|
my $version = $self->{plugin}->{meta}->{version} || '';
|
|
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta});
|
|
|
|
my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name};
|
|
if (index($plugin_pkg, 'Plugins::') < 0) {
|
|
$plugin_pkg = 'Plugins::' . $plugin_pkg;
|
|
}
|
|
|
|
$output = <<END_OF_PLUGIN;
|
|
# ==================================================================
|
|
# Auto Generated Plugin Configuration - Needed for Web Based Creator.
|
|
#
|
|
# $plugin_pkg
|
|
# Author : $author
|
|
# Version : $version
|
|
# Updated : $time
|
|
#
|
|
# ==================================================================
|
|
#
|
|
|
|
package $plugin_pkg;
|
|
# ==================================================================
|
|
$self->{initial_indent}use strict;
|
|
$self->{initial_indent}use vars qw/\$WIZARD/;
|
|
|
|
END_OF_PLUGIN
|
|
$output .= GT::Dumper->dump(var => '$WIZARD', data => $self->{plugin});
|
|
$output .= "\n\n1;\n";
|
|
return $output;
|
|
}
|
|
|
|
sub _load_tar {
|
|
# -------------------------------------------------------------------
|
|
# Loads a tar file.
|
|
#
|
|
my $self = shift;
|
|
my $file = $self->{plugin_dir} . "/Uninstalled/" . $self->{plugin}->{name} . ".tar";
|
|
if (-e $file) {
|
|
$self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error);
|
|
}
|
|
else {
|
|
$self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error);
|
|
}
|
|
}
|
|
|
|
sub _load_plugin {
|
|
# -------------------------------------------------------------------
|
|
# Loads the meta information into self.
|
|
#
|
|
my $self = shift;
|
|
my $wizard = $self->{tar}->get_file('Wizard.pm')
|
|
or return $self->error('CANTLOAD', 'WARN', $self->{plugin}->{name}, "No Wizard.pm file found in tar!");
|
|
|
|
# Eval the install file.
|
|
my $file = $wizard->body_as_string;
|
|
{
|
|
local ($@, $SIG{__DIE__}, $^W);
|
|
eval "$file";
|
|
if ($@) {
|
|
return $self->error('CANTLOAD', 'WARN', $file, "Wizard.pm does not compile: $@");
|
|
}
|
|
}
|
|
|
|
# Load the information.
|
|
|
|
my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name};
|
|
if (index($plugin_pkg, 'Plugins::') < 0) {
|
|
$plugin_pkg = 'Plugins::' . $plugin_pkg;
|
|
}
|
|
|
|
my $var = $plugin_pkg . "::WIZARD";
|
|
{
|
|
no strict 'refs';
|
|
$self->{plugin} = $$var;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub _list_editable {
|
|
# -------------------------------------------------------------------
|
|
# Returns a select list of plugins that can be edited by the wizard.
|
|
#
|
|
my $self = shift;
|
|
my $dir = $self->{plugin_dir} . '/Uninstalled';
|
|
my %plugins;
|
|
my $count = 0;
|
|
my $select = "<select name=plugin_name>";
|
|
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, "$!");
|
|
while (defined(my $file = readdir(DIR))) {
|
|
next unless ($file =~ /^(.+)\.tar$/);
|
|
my $plugin_name = $1;
|
|
$select .= "<option>$plugin_name";
|
|
$count++;
|
|
}
|
|
closedir(DIR);
|
|
$select .= "</select>";
|
|
return $count ? $select : '';
|
|
}
|
|
|
|
1;
|
|
|