838 lines
28 KiB
Perl
838 lines
28 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Plugins
|
|
# Author : Alex Krohn
|
|
# CVS Info :
|
|
# $Id: Author.pm,v 1.14 2004/01/13 01:35:18 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description: A web based admin to package new plugins.
|
|
#
|
|
|
|
package GT::Plugins::Author;
|
|
# ==================================================================
|
|
use strict;
|
|
use lib '../..';
|
|
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $ERRORS $DEBUG $PLUGIN_DIR $FONT/;
|
|
use GT::Base;
|
|
use GT::Plugins;
|
|
use GT::Template;
|
|
use GT::Dumper;
|
|
use GT::Tar;
|
|
|
|
$ATTRIBS = {
|
|
plugin_name => '',
|
|
prefix => '',
|
|
version => '',
|
|
meta => {},
|
|
pre_install => '',
|
|
install => '',
|
|
pre_uninstall => '',
|
|
uninstall => '',
|
|
header => '',
|
|
admin_menu => [],
|
|
options => {},
|
|
hooks => [],
|
|
cfg => undef,
|
|
tar => undef
|
|
};
|
|
$ERROR_MESSAGE = 'GT::Plugins';
|
|
@ISA = qw/GT::Base/;
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
|
|
$FONT = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
|
|
sub init {
|
|
# ------------------------------------------------------------------
|
|
# Create a new plugin author object, called from GT::Base on new().
|
|
#
|
|
my $self = shift;
|
|
if (! defined $PLUGIN_DIR) {
|
|
$PLUGIN_DIR = shift or return $self->error('BADARGS', 'FATAL', "new GT::Plugins::Author ( '/path/to/plugin/dir' )");
|
|
$PLUGIN_DIR .= $PLUGIN_DIR =~ m,/$, ? "Plugins" : "/Plugins";
|
|
}
|
|
$self->{cfg} = GT::Plugins->load_cfg($PLUGIN_DIR);
|
|
return $self;
|
|
}
|
|
|
|
sub list_editable {
|
|
# ------------------------------------------------------------------
|
|
# List current plugin names available to be edited.
|
|
#
|
|
my $self = shift;
|
|
my $dir = $PLUGIN_DIR . "/Author";
|
|
my @projects = ();
|
|
|
|
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
|
|
while (defined(my $file = readdir(DIR))) {
|
|
next unless ($file =~ /(.*)\.tar$/);
|
|
push @projects, $1;
|
|
}
|
|
closedir(DIR);
|
|
return \@projects;
|
|
}
|
|
|
|
sub load_plugin {
|
|
# ------------------------------------------------------------------
|
|
# Load a plugin tar file into self.
|
|
#
|
|
my ($self, $plugin_name) = @_;
|
|
$self->{plugin_name} = $plugin_name;
|
|
$self->{tar} = $self->_load_tar or return;
|
|
$self->_load_plugin;
|
|
return 1;
|
|
}
|
|
|
|
sub save {
|
|
# ------------------------------------------------------------------
|
|
# Save the current state of self into tar file.
|
|
#
|
|
my $self = shift;
|
|
$self->{plugin_name} or return $self->error('NOPLUGINNAME', 'WARN');
|
|
|
|
|
|
my ($author);
|
|
$self->{tar} or $self->_load_tar;
|
|
foreach my $file ($self->{tar}->files) {
|
|
if ($file->name =~ /Author\.pm$/) {
|
|
$author = $file;
|
|
}
|
|
}
|
|
$author ?
|
|
($author->body( $self->_create_author )) :
|
|
($author = $self->{tar}->add_data( name => 'Author.pm', body => $self->_create_author ));
|
|
|
|
# add files.
|
|
return $self->{tar}->write();
|
|
}
|
|
|
|
sub add_install {
|
|
# -------------------------------------------------------------------
|
|
# Creates the Install.pm file.
|
|
#
|
|
my $self = shift;
|
|
my $file = $self->{tar}->get_file('Install.pm');
|
|
if ($file) {
|
|
$self->_replace_install($file);
|
|
}
|
|
else {
|
|
my $time = localtime();
|
|
my $version = $self->{version} || 0;
|
|
my $meta_dump = GT::Dumper->dump( var => '$META', data => $self->{meta} );
|
|
|
|
my $output = <<END_OF_PLUGIN;
|
|
# ==================================================================
|
|
# $self->{prefix}Plugins::$self->{plugin_name} - Auto Generated Install Module
|
|
#
|
|
# $self->{prefix}Plugins::$self->{plugin_name}
|
|
# Author : $self->{meta}->{author}
|
|
# Version : $self->{version}
|
|
# Updated : $time
|
|
#
|
|
# ==================================================================
|
|
#
|
|
|
|
package $self->{prefix}Plugins::$self->{plugin_name};
|
|
# ==================================================================
|
|
use strict;
|
|
use vars qw/\$VERSION \$DEBUG \$NAME \$META/;
|
|
\$VERSION = $version;
|
|
\$DEBUG = 0;
|
|
\$NAME = '$self->{plugin_name}';
|
|
$meta_dump
|
|
$self->{header}
|
|
|
|
$self->{install}
|
|
$self->{uninstall}
|
|
$self->{pre_install}
|
|
$self->{pre_uninstall}
|
|
|
|
1;
|
|
|
|
END_OF_PLUGIN
|
|
$self->{tar}->add_data( name => 'Install.pm', body => $output );
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------------------------- #
|
|
# HTML Generationg Methods #
|
|
# ------------------------------------------------------------------------------------------------- #
|
|
|
|
sub attribs_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns a hash of attribs as html.
|
|
#
|
|
my $self = shift;
|
|
my $output = {
|
|
plugin => $self->{plugin},
|
|
version => $self->{version},
|
|
meta => $self->meta_as_html,
|
|
install => $self->install_as_html,
|
|
hooks => $self->hooks_as_html,
|
|
admin_menu => $self->admin_menu_as_html,
|
|
options => $self->options_as_html,
|
|
files => $self->files_as_html,
|
|
};
|
|
return $output;
|
|
}
|
|
|
|
sub attribs_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns a hash of attribs in form.
|
|
#
|
|
my $self = shift;
|
|
my $output = {
|
|
plugin => $self->{plugin},
|
|
version => $self->{version},
|
|
meta => $self->meta_as_form,
|
|
install => $self->install_as_form,
|
|
hooks => $self->hooks_as_form,
|
|
admin_menu => $self->admin_menu_as_form,
|
|
options => $self->options_as_form,
|
|
files => $self->files_as_form,
|
|
};
|
|
return $output;
|
|
}
|
|
|
|
sub attribs_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Load author from a cgi object.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
$self->meta_from_cgi($cgi);
|
|
$self->install_from_cgi($cgi);
|
|
$self->hooks_from_cgi($cgi);
|
|
$self->admin_menu_from_cgi($cgi);
|
|
$self->options_from_cgi($cgi);
|
|
$self->files_from_cgi($cgi);
|
|
}
|
|
|
|
sub meta_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as html.
|
|
#
|
|
my $self = shift;
|
|
my $output = qq~
|
|
<tr><td><$FONT>Version:</font></td><td><$FONT>~ . _escape_html($self->{version}) . qq~</font></td></tr>
|
|
<tr><td><$FONT>Author:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{author}) . qq~</font></td></tr>
|
|
<tr><td><$FONT>URL:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{url}) . qq~</font></td></tr>
|
|
<tr><td valign=top><$FONT>Description:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{description}) . qq~</font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub meta_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as form.
|
|
#
|
|
my $self = shift;
|
|
my $output = qq~
|
|
<tr><td><$FONT>Version:</font></td><td><$FONT><input type="text" name="version" value="~ . _escape_html($self->{version}) . qq~"></font></td></tr>
|
|
<tr><td><$FONT>Author:</font></td><td><$FONT><input type="text" name="author" value="~ . _escape_html($self->{meta}->{author}) . qq~"></font></td></tr>
|
|
<tr><td><$FONT>URL:</font></td><td><$FONT><input type="text" name="url" value="~ . _escape_html($self->{meta}->{url}) . qq~"></font></td></tr>
|
|
<tr><td valign="top"><$FONT>Description:</font></td><td><$FONT><textarea cols=50 rows=5 name="description">~ . _escape_html($self->{meta}->{description}) . qq~</textarea></font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub meta_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Takes meta information from CGI object and stores it in self.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
$self->{version} = $cgi->param('version');
|
|
$self->{meta}->{author} = $cgi->param('author');
|
|
$self->{meta}->{url} = $cgi->param('url');
|
|
$self->{meta}->{description} = $cgi->param('description');
|
|
}
|
|
|
|
sub install_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns the install information as html.
|
|
#
|
|
my $self = shift;
|
|
$self->_load_install;
|
|
my $output = qq~
|
|
<tr><td valign=top><$FONT>Pre Install Message:</font></td><td><$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
|
<tr><td valign=top><$FONT>Post Install Message:</font></td><td><$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
|
<tr><td valign=top><$FONT>Install Code:</font></td><td><$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
|
<tr><td valign=top><$FONT>Uninstall Code:</font></td><td><$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub install_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns the install information as a form.
|
|
#
|
|
my $self = shift;
|
|
$self->_load_install;
|
|
my $output = qq~
|
|
<tr><td valign=top><$FONT>Pre Install Message:<br>
|
|
<input type="submit" name="preinst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_install">~ . _escape_html($self->{pre_install}) . qq~</textarea></font></td></tr>
|
|
<tr><td valign=top><$FONT>Post Install Message:<br>
|
|
<input type="submit" name="preuninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_uninstall">~ . _escape_html($self->{pre_uninstall}) . qq~</textarea></font></td></tr>
|
|
<tr><td valign=top><$FONT>Install Code:<br>
|
|
<input type="submit" name="inst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="install">~ . _escape_html($self->{install}) . qq~</textarea></font></td></tr>
|
|
<tr><td valign=top><$FONT>Uninstall Code:<br>
|
|
<input type="submit" name="uninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 wrap="off" rows=8 name="uninstall">~ . _escape_html($self->{uninstall}) . qq~</textarea></font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub install_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Sets the install information from a CGI object.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
|
|
if ($cgi->param('inst_auto_generate')) {
|
|
$self->{install} = $self->_create_install;
|
|
}
|
|
elsif ($cgi->param('preinst_auto_generate')) {
|
|
$self->{pre_install} = $self->_create_preinstall;
|
|
}
|
|
elsif ($cgi->param('preuninst_auto_generate')) {
|
|
$self->{pre_uninstall} = $self->_create_preuninstall;
|
|
}
|
|
elsif ($cgi->param('uninst_auto_generate')) {
|
|
$self->{uninstall} = $self->_create_uninstall;
|
|
}
|
|
else {
|
|
$self->{pre_install} = $cgi->param('pre_install');
|
|
$self->{pre_uninstall} = $cgi->param('pre_uninstall');
|
|
$self->{install} = $cgi->param('install');
|
|
$self->{uninstall} = $cgi->param('uninstall');
|
|
}
|
|
}
|
|
|
|
sub hooks_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns plugin hooks as html.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (@{$self->{hooks}}) {
|
|
foreach my $hook (@{$self->{hooks}}) {
|
|
my ($hook_name, $prepost, $code) = @$hook;
|
|
$output .= qq~
|
|
<tr><td><$FONT>$hook_name ($prepost)</font></td><td><$FONT>$code</font></td></tr>
|
|
~;
|
|
}
|
|
}
|
|
else {
|
|
$output = qq~
|
|
<tr><td><$FONT>No hooks installed</font></td></tr>
|
|
~;
|
|
}
|
|
return $output;
|
|
}
|
|
|
|
sub hooks_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns plugin hooks as form.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (@{$self->{hooks}}) {
|
|
$output = qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Hooks</font></td></tr>
|
|
~;
|
|
my $i = 0;
|
|
foreach my $hook (@{$self->{hooks}}) {
|
|
my ($hook_name, $prepost, $code) = @$hook;
|
|
$output .= qq~
|
|
<tr><td><$FONT>$hook_name ($prepost) => $code</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_hooks" value="$i"></font></td></tr>
|
|
~;
|
|
$i++;
|
|
}
|
|
}
|
|
my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::";
|
|
$output .= qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Hook</font></td></tr>
|
|
<tr><td><$FONT>Hook: <input type="text" name="hook_name" size="10"> <select name="prepost"><option>PRE<option>POST</select></font></td>
|
|
<td><$FONT>Code: <input type="text" name="code" value="$pkg"></font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub hooks_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Sets the hook info based on CGI object.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
my @to_delete = $cgi->param('delete_hooks');
|
|
foreach my $delete_pos (@to_delete) {
|
|
splice(@{$self->{hooks}}, $delete_pos, 1);
|
|
}
|
|
if ($cgi->param('hook_name')) {
|
|
my ($name, $prepost, $code) = ($cgi->param('hook_name'), uc $cgi->param('prepost'), $cgi->param('code'));
|
|
push @{$self->{hooks}}, [$name, $prepost, $code];
|
|
}
|
|
}
|
|
|
|
sub admin_menu_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as html.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (@{$self->{admin_menu}}) {
|
|
foreach my $menu (@{$self->{admin_menu}}) {
|
|
my $menu_name = _escape_html($menu->[0]);
|
|
my $menu_url = _escape_html($menu->[1]);
|
|
$output .= qq~
|
|
<tr><td><$FONT>$menu_name</font></td><td><$FONT>=> $menu_url</font></td></tr>
|
|
~;
|
|
}
|
|
}
|
|
else {
|
|
$output = qq~
|
|
<tr><td><$FONT>No Admin Menu options installed</font></td></tr>
|
|
~;
|
|
}
|
|
return $output;
|
|
}
|
|
|
|
sub admin_menu_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as form.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (@{$self->{admin_menu}}) {
|
|
$output = qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Admin Menu options</font></td></tr>
|
|
~;
|
|
my $i = 0;
|
|
foreach my $menu (@{$self->{admin_menu}}) {
|
|
my $menu_name = _escape_html($menu->[0]);
|
|
my $menu_url = _escape_html($menu->[1]);
|
|
$output .= qq~
|
|
<tr><td><$FONT>$menu_name => $menu_url</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_admin_menu" value="$i"></font></td></tr>
|
|
~;
|
|
$i++;
|
|
}
|
|
}
|
|
$output .= qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Menu</font></td></tr>
|
|
<tr><td><$FONT>Name: <input type="text" name="menu_name" size="10"></font></td>
|
|
<td><$FONT>URL: <input type="text" name="menu_url" size="20"></font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub admin_menu_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Sets the admin menu info based on CGI object.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
my @to_delete = $cgi->param('delete_admin_menu');
|
|
foreach my $delete_pos (@to_delete) {
|
|
splice(@{$self->{admin_menu}}, $delete_pos, 1);
|
|
}
|
|
if ($cgi->param('menu_name')) {
|
|
my ($name, $url) = ($cgi->param('menu_name'), $cgi->param('menu_url'));
|
|
push @{$self->{admin_menu}}, [$name, $url];
|
|
}
|
|
}
|
|
|
|
sub options_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as html.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (keys %{$self->{options}}) {
|
|
foreach my $key (sort keys %{$self->{options}}) {
|
|
$output .= qq~
|
|
<tr><td><$FONT>~ . _escape_html($key) . qq~</font></td><td><$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~</font></td></tr>
|
|
~;
|
|
}
|
|
}
|
|
else {
|
|
$output = qq~
|
|
<tr><td><$FONT>No user options installed</font></td></tr>
|
|
~;
|
|
}
|
|
return $output;
|
|
}
|
|
|
|
sub options_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as form.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
if (keys %{$self->{options}}) {
|
|
$output = qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed User options</font></td></tr>
|
|
~;
|
|
my $i = 0;
|
|
foreach my $key (sort keys %{$self->{options}}) {
|
|
$output .= qq~
|
|
<tr><td><$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_options" value="~ . _escape_html($key) . qq~"></font></td></tr>
|
|
~;
|
|
$i++;
|
|
}
|
|
}
|
|
$output .= qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Option</font></td></tr>
|
|
<tr><td><$FONT>Name: <input type="text" name="add_key" size="10"></font></td>
|
|
<td><$FONT>Default: <input type="text" name="add_val" size="20"></font></td></tr>
|
|
~;
|
|
return $output;
|
|
}
|
|
|
|
sub options_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Sets the options based on the user input.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
my @to_delete = $cgi->param('delete_options');
|
|
foreach my $key (@to_delete) {
|
|
delete $self->{options}->{$key};
|
|
}
|
|
my ($key, $value) = ($cgi->param('add_key'), $cgi->param('add_val'));
|
|
if (defined $key and $key) {
|
|
$self->{options}->{$key} = $value;
|
|
}
|
|
}
|
|
|
|
sub files_as_html {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as html.
|
|
#
|
|
my $self = shift;
|
|
my $output;
|
|
my $num_files = 0;
|
|
if ($self->{tar}) {
|
|
my $files = $self->{tar}->files;
|
|
foreach my $file (@$files) {
|
|
my $name = $file->name;
|
|
my $size = $file->size;
|
|
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
|
next if ($name =~ /Author\.pm$/);
|
|
$output .= qq~
|
|
<tr><td><$FONT>$name</font></td><td><$FONT>$size</font></td></tr>
|
|
~;
|
|
$num_files++;
|
|
}
|
|
}
|
|
if (! $num_files) {
|
|
$output = qq~
|
|
<tr><td><$FONT>No extra files installed</font></td></tr>
|
|
~;
|
|
}
|
|
return $output;
|
|
}
|
|
|
|
sub files_as_form {
|
|
# ----------------------------------------------------------------
|
|
# Returns meta info + version as form.
|
|
#
|
|
my ($self, $edit_url) = @_;
|
|
my $output;
|
|
my $num_files = 0;
|
|
if ($self->{tar}) {
|
|
my $files = $self->{tar}->files;
|
|
foreach my $file (@$files) {
|
|
my $name = _escape_html($file->name);
|
|
my $size = $file->size;
|
|
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
|
next if ($name =~ /Author\.pm$/);
|
|
$output .= qq~
|
|
<tr><td><$FONT>$name</font></td><td><$FONT>($size)</font></td></tr>
|
|
~;
|
|
$num_files++;
|
|
}
|
|
}
|
|
if ($num_files) {
|
|
$output = qq~
|
|
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Files</font></td></tr>
|
|
$output
|
|
~;
|
|
}
|
|
return $output;
|
|
}
|
|
|
|
sub files_from_cgi {
|
|
# ----------------------------------------------------------------
|
|
# Set the file information.
|
|
#
|
|
my ($self, $cgi) = @_;
|
|
$self->{tar} or $self->_load_tar;
|
|
my $filename = $cgi->param('add_name');
|
|
my $filehandle = $cgi->param('add_file');
|
|
my $body = $cgi->param('add_body');
|
|
if ($filename) {
|
|
if (ref $filehandle) {
|
|
my ($buffer, $read);
|
|
while ($read = read($filehandle, $buffer, 4096)) {
|
|
$body .= $buffer;
|
|
}
|
|
}
|
|
if (! $body) {
|
|
$body = ' ';
|
|
}
|
|
$body =~ s/\r//g;
|
|
my $res = $self->{tar}->add_data( name => $filename, body => $body );
|
|
}
|
|
my @to_delete = $cgi->param('delete_files');
|
|
foreach my $file (@to_delete) {
|
|
$self->{tar}->remove_file($file);
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------------------------- #
|
|
# Private Methods #
|
|
# ------------------------------------------------------------------------------------------------- #
|
|
|
|
sub _load_plugin {
|
|
# ----------------------------------------------------------------
|
|
# Examines a plugin tar and fills up self with info.
|
|
#
|
|
my $self = shift;
|
|
my $author = $self->{tar}->get_file('Author.pm') or return $self->error('CANTLOAD', 'WARN', $self->{plugin_name}, "No Author.pm file found in tar!");
|
|
|
|
# Eval the install file.
|
|
my $file = $author->body_as_string;
|
|
{
|
|
local ($@, $SIG{__DIE__}, $^W);
|
|
eval "$file";
|
|
if ($@) {
|
|
return $self->error('CANTLOAD', 'WARN', $file, "Author.pm does not compile: $@");
|
|
}
|
|
}
|
|
|
|
# Load the information.
|
|
no strict 'refs';
|
|
my $var = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::AUTHOR";
|
|
my $author_info = ${$var};
|
|
if (ref $author_info eq 'HASH') {
|
|
foreach my $key (keys %$author_info) {
|
|
$self->{$key} = $author_info->{$key};
|
|
}
|
|
}
|
|
use strict 'refs';
|
|
$self->_load_install;
|
|
return 1;
|
|
}
|
|
|
|
sub _load_tar {
|
|
# -------------------------------------------------------------------
|
|
# Loads the tar file into memory.
|
|
#
|
|
my $self = shift;
|
|
my $file = $PLUGIN_DIR . "/Author/" . $self->{plugin_name} . ".tar";
|
|
if (-e $file) {
|
|
$self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
|
}
|
|
else {
|
|
$self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
|
}
|
|
}
|
|
|
|
sub _create_author {
|
|
# -------------------------------------------------------------------
|
|
# Creates the author.pm file used by the web tool to auto create the plugin.
|
|
#
|
|
my $self = shift;
|
|
my $output = '';
|
|
my $time = localtime();
|
|
my $version = $self->{version} || 0;
|
|
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta});
|
|
|
|
$output = <<END_OF_PLUGIN;
|
|
# ==================================================================
|
|
# Auto Generated Plugin Configuration - Needed for Web Based Creator.
|
|
#
|
|
# $self->{prefix}Plugins::$self->{plugin_name}
|
|
# Author : $self->{meta}->{author}
|
|
# Version : $self->{version}
|
|
# Updated : $time
|
|
#
|
|
# ==================================================================
|
|
#
|
|
|
|
package $self->{prefix}Plugins::$self->{plugin_name};
|
|
# ==================================================================
|
|
use strict;
|
|
use vars qw/\$AUTHOR/;
|
|
|
|
END_OF_PLUGIN
|
|
my $author = {};
|
|
foreach (keys %$ATTRIBS) {
|
|
next if ($_ eq 'tar');
|
|
$author->{$_} = $self->{$_};
|
|
}
|
|
$output .= GT::Dumper->dump(var => '$AUTHOR', data => $author);
|
|
$output .= "\n\n1;\n";
|
|
return $output;
|
|
}
|
|
|
|
sub _escape_html {
|
|
# -------------------------------------------------------------------
|
|
# Escape html.
|
|
#
|
|
my $val = shift;
|
|
defined $val or return '';
|
|
$val =~ s/&/&/g;
|
|
$val =~ s/</</g;
|
|
$val =~ s/>/>/g;
|
|
$val =~ s/"/"/g;
|
|
return $val;
|
|
}
|
|
|
|
sub _create_install {
|
|
# -------------------------------------------------------------------
|
|
# Auto generate the install function.
|
|
#
|
|
my $self = shift;
|
|
my $code = qq~
|
|
sub install {
|
|
# -------------------------------------------------------------------
|
|
# Auto-generated install function. Must return status message to user.
|
|
#
|
|
my \$mgr = new GT::Plugins::Manager;~;
|
|
foreach my $hook (@{$self->{hooks}}) {
|
|
$code .= qq~
|
|
\$mgr->install_hooks('$self->{plugin_name}', [['$hook->[0]', '$hook->[1]', '$hook->[2]']]);~;
|
|
}
|
|
foreach my $menu (@{$self->{admin_menu}}) {
|
|
$code .= qq~
|
|
\$mgr->install_menu('$self->{plugin_name}', [['$menu->[0]', '$menu->[1]']]);~;
|
|
}
|
|
if (keys %{$self->{options}}) {
|
|
my $options = GT::Dumper->dump(var => '$opts', data => $self->{options});
|
|
$options =~ s/\n/\n\t/g;
|
|
$code .= qq~
|
|
my $options
|
|
\$mgr->install_options('$self->{plugin_name}', \$opts);~;
|
|
}
|
|
$code .= qq~
|
|
return "Plugin $self->{plugin_name} installed successfully.";
|
|
}
|
|
~;
|
|
return $code;
|
|
}
|
|
|
|
sub _create_uninstall {
|
|
# -------------------------------------------------------------------
|
|
# Auto generate the pre-install function.
|
|
#
|
|
my $self = shift;
|
|
my $code = qq~
|
|
sub uninstall {
|
|
# -------------------------------------------------------------------
|
|
# Auto-generated uninstall function. Must return status message to user.
|
|
#
|
|
my \$message = "Plugin $self->{plugin_name} has been uninstalled.";
|
|
return \$message;
|
|
}
|
|
~;
|
|
return $code;
|
|
}
|
|
|
|
sub _create_preinstall {
|
|
# -------------------------------------------------------------------
|
|
# Auto generate the pre-install function.
|
|
#
|
|
my $self = shift;
|
|
my $code = qq~
|
|
sub pre_install {
|
|
# -------------------------------------------------------------------
|
|
# Auto-generated pre_install function. Must return status message to user.
|
|
#
|
|
my \$message = "INSERT INSTALL MESSAGE HERE";
|
|
return \$message;
|
|
}
|
|
~;
|
|
return $code;
|
|
}
|
|
|
|
sub _create_preuninstall {
|
|
# -------------------------------------------------------------------
|
|
# Auto generate the pre-install function.
|
|
#
|
|
my $self = shift;
|
|
my $code = qq~
|
|
sub pre_uninstall {
|
|
# -------------------------------------------------------------------
|
|
# Auto-generated pre_uninstall function. Must return status message to user.
|
|
#
|
|
my \$message = "INSERT UNINSTALL MESSAGE HERE";
|
|
return \$message;
|
|
}
|
|
~;
|
|
return $code;
|
|
}
|
|
|
|
sub _load_install {
|
|
# -------------------------------------------------------------------
|
|
# Load the install functions from the Install.pm file.
|
|
#
|
|
my $self = shift;
|
|
return unless ($self->{tar});
|
|
my $install = $self->{tar}->get_file('Install.pm') or return;
|
|
my $install_code = $install->body_as_string;
|
|
$self->{pre_install} = $self->_parse_sub('pre_install', \$install_code);
|
|
$self->{install} = $self->_parse_sub('install', \$install_code);
|
|
$self->{pre_uninstall} = $self->_parse_sub('pre_uninstall', \$install_code);
|
|
$self->{uninstall} = $self->_parse_sub('uninstall', \$install_code);
|
|
}
|
|
|
|
sub _replace_install {
|
|
# -------------------------------------------------------------------
|
|
# Load the install functions from the Install.pm file.
|
|
#
|
|
my ($self, $install) = @_;
|
|
return unless ($install);
|
|
|
|
my $install_code = $install->body_as_string;
|
|
$install_code =~ s/\r//g;
|
|
$self->_replace_sub('pre_install', \$install_code, $self->{pre_install});
|
|
$self->_replace_sub('install', \$install_code, $self->{install});
|
|
$self->_replace_sub('pre_uninstall', \$install_code, $self->{pre_uninstall});
|
|
$self->_replace_sub('uninstall', \$install_code, $self->{uninstall});
|
|
$install_code =~ s/(\$VERSION\s*=\s*)(['"]?)[\d\.]+(['"]?)/$1$2$self->{version}$3/;
|
|
$install_code =~ s/(Version\s*:\s*)[\d\.]+/$1$self->{version}/;
|
|
$install_code =~ s/\$META\s*=\s*[^\}]+\}[\s\n]*;[\s\n]*/GT::Dumper->dump(var => '$META', data => $self->{meta}) . "\n"/esm;
|
|
$install->body($install_code);
|
|
}
|
|
|
|
sub _parse_sub {
|
|
# -------------------------------------------------------------------
|
|
# Parse out a subroutine in some code, and return it.
|
|
#
|
|
my ($self, $sub, $code) = @_;
|
|
return '' unless ($sub and $$code);
|
|
|
|
$$code =~ m/(\s*)(sub\s+$sub[^\{]*\{.*?\n\1\})/sm;
|
|
my $code_block = $2 || '';
|
|
$code_block =~ s/\r//g;
|
|
return $code_block;
|
|
}
|
|
|
|
sub _replace_sub {
|
|
# -------------------------------------------------------------------
|
|
# Parse out a subroutine in some code, and replace it.
|
|
#
|
|
my ($self, $sub, $code, $new) = @_;
|
|
return unless ($new);
|
|
$new =~ s/\r//g;
|
|
$new =~ s/^[\s\n]+|[\s\n]$//g;
|
|
$$code =~ s/\r//g;
|
|
if (! ($$code =~ s/([\s\n]*)(sub\s+$sub[^\{]*\{.*?\n\1\})/\n$new/sm)) {
|
|
$$code =~ s/1;[\s\n\r]+$//gsm;
|
|
$$code .= "\n" . $new . "\n1;\n\n";
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
1;
|