# ==================================================================
# 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;