discourse-legacysite-perl/site/glist/lib/GT/Plugins/Author.pm
2024-06-17 21:49:12 +10:00

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/&/&amp;/g;
$val =~ s/</&lt;/g;
$val =~ s/>/&gt;/g;
$val =~ s/"/&quot;/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;