First pass at adding key files
This commit is contained in:
dsainty
836
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Author.pm
Normal file
836
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Author.pm
Normal file
@@ -0,0 +1,836 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Author.pm,v 1.15 2006/06/27 01:44:53 brewt 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 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.15 $ =~ /(\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;
|
||||
266
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm
Normal file
266
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm
Normal file
@@ -0,0 +1,266 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to install/uninstall plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Installer;
|
||||
# ==================================================================
|
||||
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.15 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
plugin_dir => undef,
|
||||
prog_ver => undef,
|
||||
prog_user_cgi => undef,
|
||||
prog_admin_cgi => undef,
|
||||
prog_images => undef,
|
||||
prog_libs => 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});
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
# Utilities used in Install/Uninstall by Plugins #
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
|
||||
sub install_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of plugin hooks.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
if (ref $hooks ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['hookname', 'PRE/POST', 'action', status], ...])");
|
||||
}
|
||||
if (ref $hooks->[0] ne 'ARRAY') {
|
||||
$hooks = [ $hooks ];
|
||||
}
|
||||
foreach my $hook (@$hooks) {
|
||||
my ($hookname, $prepost, $action, $status) = @$hook;
|
||||
if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) {
|
||||
die "Invalid hook argument. Must be pre/post, not: $prepost";
|
||||
}
|
||||
# Allow a hook to be installed as disabled by default, but for backwards compatibility, it has to be a 0 (not just a false value).
|
||||
$status = (defined $status and $status ne '' and $status == 0) ? 0 : 1;
|
||||
push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, $status];
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of menu options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
if (ref $menus ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['title', 'url'], ...])");
|
||||
}
|
||||
if (ref $menus->[0] ne 'ARRAY') {
|
||||
$menus = [ $menus ];
|
||||
}
|
||||
foreach my $menu (@$menus) {
|
||||
push @{$self->{cfg}->{$plugin}->{menu}}, $menu;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts, ) = @_;
|
||||
if (ref $opts ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', [['name', 'val', 'instructions'] ...])");
|
||||
}
|
||||
if (ref $opts->[0] ne 'ARRAY') {
|
||||
$opts = [ $opts ];
|
||||
}
|
||||
foreach my $opt (@$opts) {
|
||||
exists $self->{cfg}->{$plugin}->{user} or ($self->{cfg}->{$plugin}->{user} = []);
|
||||
push @{$self->{cfg}->{$plugin}->{user}}, $opt;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a registry item for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
if (ref $opts ne 'HASH') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', { key => value, ... })");
|
||||
}
|
||||
my $registry = ($self->{cfg}->{$plugin}->{registry} ||= {});
|
||||
foreach my $key (keys %$opts) {
|
||||
$registry->{$key} = $opts->{$key};
|
||||
}
|
||||
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub uninstall_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove plugins, just a no-op as the config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove menus, no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove options, just a no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove registry, just a no-op as config gets deleted.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins::Installer
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$mgr->install_hooks('PluginName', ['hook_name', 'PRE|POST', 'code', status]);
|
||||
$mgr->install_menu('PluginName', ['menu_name', 'menu_url', 'enabled']);
|
||||
$mgr->install_options('PluginName', ['option_key', 'option_val', 'instructions']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The installer is an object that is passed into plugins during installation.
|
||||
It provides methods to add hooks, menu options, admin options or copy files
|
||||
into the users application.
|
||||
|
||||
=head2 install_hooks
|
||||
|
||||
C<install_hooks> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item hook_name
|
||||
|
||||
The hook you want to override.
|
||||
|
||||
=item PRE/POST
|
||||
|
||||
Either the string PRE or POST depending on whether the hook should be run
|
||||
before the main code, or after.
|
||||
|
||||
=item code
|
||||
|
||||
The name of the code to run. It should be Plugins::PACKAGE::YourPluginName::function.
|
||||
Where PACKAGE is the name of the Gossamer Product the plugin is for. For example
|
||||
Plugins::GMail::Wap::header
|
||||
|
||||
=item status
|
||||
|
||||
Whether or not the hook will be enabled or disabled. For backwards
|
||||
compatibility, if this option is set to anything but '0' then the hook will be
|
||||
enabled.
|
||||
|
||||
=back
|
||||
|
||||
C<install_hooks> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_menu
|
||||
|
||||
C<install_menu> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item menu_name
|
||||
|
||||
The name that will show up in the admin menu.
|
||||
|
||||
=item menu_url
|
||||
|
||||
The URL for the menu option.
|
||||
|
||||
=item enabled
|
||||
|
||||
Either true or false depending on whether the menu option should be shown.
|
||||
|
||||
=back
|
||||
|
||||
C<install_menu> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_options
|
||||
|
||||
C<install_options> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item option_key
|
||||
|
||||
This is the key, and is used when accessing the options hash.
|
||||
|
||||
=item option_value
|
||||
|
||||
This is the default value.
|
||||
|
||||
=item instructions
|
||||
|
||||
A string instruction users on what the plugin does.
|
||||
|
||||
=back
|
||||
|
||||
C<install_options> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt Exp $
|
||||
|
||||
=cut
|
||||
1189
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm
Normal file
1189
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm
Normal file
File diff suppressed because it is too large
Load Diff
1098
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm
Normal file
1098
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user