| <$font>Plugin Name |
<$font>Latest Version |
<$font>Action |
~;
foreach my $p (@plugins) {
$count++;
next if $nh > 1 and $count < $beg + 1;
my %row;
($row{plg_id}, $row{plg_name}, $row{plg_version}, $row{plg_url}, $row{plg_support}, $row{plg_support_url}, $row{plg_language}, $row{plg_updated}, $row{plg_license}, $row{plg_price}, $row{plg_author}, $row{cli_id_fk}, $row{author_name}, $row{plg_description}) = split /\t/, $p;
$row{plg_updated} = GT::Date::date_get($row{plg_updated}, "%ddd%, %mmm% %dd% %yyyy% %hh%:%MM%:%ss%") if $row{plg_updated};
my $fetch = "$url/$row{plg_name}.tar?id=$row{plg_id};reg_number=$reg_number";
$row{download_url} = $self->{cgi}->escape($fetch);
$row{installed} = $plugin_cfg->{$row{plg_name}} ? $plugin_cfg->{$row{plg_name}}->{version} : '';
push @output, \%row;
my $price = $row{plg_license} == 2 ? $row{plg_price} : 'Free';
$output .= qq~
<$font>$row{plg_name}
Author: $row{author_name}
Last Updated: $row{plg_updated}
Description:
$row{plg_description}
Price: $price
|
<$font>$row{plg_version} |
<$font>Download |
~;
last if @output == $mh;
}
if ($hits > $mh) {
my $pages = int($hits / $mh);
$pages++ if $hits % $mh;
for my $i (1..$pages) {
$self->{cgi}->param('nh', $i);
my $url = $self->{cgi}->url;
$speedbar .= $i == $nh ? "$i " : "$i ";
}
}
$output = qq~
<$font>There are $hits plugins available for download.
$speedbar
$output
|
$speedbar
~;
return { plugins => \@output, num_plugins => $hits, speedbar => $speedbar, base_url => $self->{base_url}, gossamer => $output };
}
sub download_file {
# -------------------------------------------------------------------
# Place the upload file into the Uninstalled directory.
#
my $self = shift;
my $file = $self->{cgi}->param('file');
if (! $file) {
return { error => "Please press browse to pick a file before uploading." };
}
my ($name) = $file =~ m,([^/\\]+)$,;
if ($name !~ /^[\w\-\.]+\.tar$/) {
return { error => "Invalid file name: $name. Must be a .tar file, and only be letters and numbers, no spaces." };
}
my $full_path = $self->{plugin_dir} . "/Uninstalled/" . $name;
open (FILE, "> $full_path") or return { error => "Unable to create file: $full_path ($!)" };
binmode FILE; # Output stream
binmode $file; # Input stream
my ($read, $buffer);
while ($read = read($file, $buffer, 4096)) {
print FILE $buffer;
}
close FILE;
return { results => "File was uploaded successfully." };
}
sub download_url {
# -------------------------------------------------------------------
# Fetch a plugin from a URL and save it to the folder.
#
my $self = shift;
my $url = $self->{cgi}->param('url');
$url or return { error => "Please enter a valid url." };
require GT::WWW;
my ($protocol) = GT::WWW->parse_url($url);
return { error => "Invalid URL specified" } unless $protocol;
unless (GT::WWW->protocol_supported($protocol)) {
return { error => "Unsupported protocol entered: $protocol" };
}
my ($fh, $plugin_file, $full_path, $plugin_error, $status_error, $open_error, $no_filename, $print_error);
my $www = GT::WWW->new($url);
$www->chunk_size(16 * 1024); # Get 16KB at a time
$www->chunk(sub {
my $chunk = shift;
unless ($fh or defined $plugin_error) {
my $response = $www->response;
my $status = $response->status;
my $header = $response->header;
if ($status_error = not $status) {
$www->cancel;
return;
}
if ($header->contains('X-Plugins' => 'Error')) {
$plugin_error = '';
}
else {
$plugin_file = {$header->header_words('Content-Disposition')}->{filename};
unless ($plugin_file) {
if (!$www->query_string) {
my $path = $www->path;
($plugin_file) = $path =~ m{/([^/]+)\.tar$};
$plugin_file .= ".tar" if $plugin_file;
}
unless ($plugin_file) {
$open_error = "No plugin found at url: $url";
$no_filename = 1;
$www->cancel;
return;
}
}
$fh = \do { local *PLUGIN; *PLUGIN };
$full_path = "$self->{plugin_dir}/Uninstalled/$plugin_file";
unless (open $fh, "> $full_path") {
$open_error = "Unable to create file '$full_path': $!";
$www->cancel;
return;
}
binmode $fh;
}
}
if (defined $plugin_error) { $plugin_error .= $$chunk }
else {
unless (print $fh $$chunk) {
$print_error = "Unable to continue writing to file '$full_path': $!. Removing partial file.";
$www->cancel;
unlink $full_path;
}
}
});
my $response = $www->get or return { error => "Unable to retrieve plugin: " . $www->error };
$status_error and return { error => "Unable to retrieve plugin: Server returned error status: " . (int $response->status) . $response->status };
defined $plugin_error and return { error => $plugin_error };
$open_error and return { error => $open_error };
$print_error and return { error => $print_error };
return { results => "Plugin $plugin_file retrieved successfully." };
}
# ------------------------------------------------------------------------------------------------- #
# Utilities #
# ------------------------------------------------------------------------------------------------- #
sub admin_menu {
# ----------------------------------------------------------------
# Displays the admin menu.
#
my $self = shift;
my $menu = '';
foreach my $plugin (sort keys %{$self->{cfg}}) {
next unless ($self->{cfg}->{$plugin}->{menu});
$menu .= qq~
$plugin
~;
foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) {
next if (defined $menu_option->[2] and ! $menu_option->[2]);
$menu .= qq~ $menu_option->[0]
~;
}
$menu .= " ";
}
if ($menu) {
$menu = qq~
| Installed
Plugins |
$menu
~;
}
return $menu;
}
sub installed_plugins {
# ----------------------------------------------------------------
# Returns a list of installed plugins, not formatted.
#
my $self = shift;
my $plgs = {};
foreach my $plugin (keys %{$self->{cfg}}) {
next if (substr($plugin, 0, 1) eq '_');
$plgs->{$plugin} = $self->{cfg}->{$plugin};
}
return $plgs;
}
sub installed_plugins_html {
# ----------------------------------------------------------------
# Returns a formatted string of installed plugins.
#
my $self = shift;
my $plugins = $self->installed_plugins;
my $count = 0;
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
my $html = qq~
| <$font>Installed Plugins |
| <$font>Name |
<$font>Version |
<$font>Author |
<$font>Action |
~;
# Show installed plugins.
my $base = $self->{base_url};
foreach my $name (sort keys %$plugins) {
my $plugin = $plugins->{$name};
my $plugin_e= $self->{cgi}->escape($name);
my $title = $plugin->{meta}->{title} || $name;
my $author = $plugin->{meta}->{author} || 'Unknown Author';
my $url = $plugin->{meta}->{url} || '';
my $version = $plugin->{version} || 'Unknown Version';
$url and ($author = qq~$author~);
$html .= qq~
| <$font>$title |
<$font>$version |
<$font>$author |
<$font>Edit |
Uninstall |
~;
$count++;
}
$html .= " |
";
if (! $count) {
$html = "| No plugins have been installed. |
|
";
}
return $html;
}
sub uninstalled_plugins {
# ----------------------------------------------------------------
# Returns a list of uninstalled plugins, not formatted.
#
my $self = shift;
my $dir = $self->{plugin_dir} . '/Uninstalled';
my %plugins;
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
while (defined(my $file = readdir(DIR))) {
next unless ($file =~ /^(.+)\.tar$/);
my $plugin_name = $1;
my $tar = $self->_open_tar($plugin_name, 'Uninstalled');
$tar or $plugins{$plugin_name} = { tar_error => $GT::Plugins::error } and next;
my $plugin = $self->_load_plugin_install($tar, $plugin_name);
$plugin or $plugins{$plugin_name} = { inst_error => $GT::Plugins::error } and next;
$plugins{$plugin_name} = $plugin;
}
closedir(DIR);
return \%plugins;
}
sub uninstalled_plugins_html {
# ----------------------------------------------------------------
# Returns a formatted string of uninstalled plugins.
#
my $self = shift;
my $plugins = $self->uninstalled_plugins;
my $count = 0;
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
my $html = qq~
| <$font>Uninstalled Plugins |
| <$font>Name |
<$font>Version |
<$font>Author |
<$font>Action |
~;
my $base = $self->{base_url};
my $func = $self->{func_url} ? $self->{func_url} : "$base&do=plugin";
foreach my $name (sort keys %$plugins) {
my $plugin = $plugins->{$name};
my $plugin_e= $self->{cgi}->escape($name);
my $title = $plugin->{meta}->{title} || $name;
my $author = $plugin->{meta}->{author} || 'Unknown Author';
my $url = $plugin->{meta}->{url} || '';
my $version = $plugin->{version} || 'Unknown Version';
my $tar_err = $plugin->{tar_error} || '';
my $inst_err = $plugin->{inst_error} || '';
my $inst_l = qq~Install |~;
my $edit_l = qq~Edit |~;
my $error = '';
if ($tar_err) {
$error = "
$tar_err";
$inst_l = '';
$edit_l = '';
}
if ($inst_err) {
$error = "
$inst_err";
$inst_l = '';
}
$url and ($author = qq~$author~);
$html .= qq~
| <$font>$title$error |
<$font>$version |
<$font>$author |
<$font>$inst_l $edit_l
Delete
| Download |
~;
$count++;
}
$html .= " |
";
if (! $count) {
$html = "| No plugins are available to be installed. |
|
";
}
return $html;
}
sub uninstalled_plugin_info {
# ----------------------------------------------------------------
# Returns a hash of plugin info for an uninstalled plugin.
#
my ($self, $plugin_name) = @_;
my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar";
if (! -e $file) {
return $self->error('CANTOPEN', 'WARN', $file, $!);
}
my $tar = GT::Tar->open($file) or return;
my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return;
return $plugin;
}
sub installed_plugin_info {
# ----------------------------------------------------------------
# Return a hash of plugin info for an installed plugin.
#
my ($self, $plugin_name) = @_;
return exists $self->{cfg}->{$plugin_name} ?
$self->{cfg}->{$plugin_name} :
$self->error('NOPLUGIN', 'WARN', $plugin_name);
}
sub _open_tar {
# ----------------------------------------------------------------
# Opens a tar file.
#
my ($self, $plugin_name, $dir) = @_;
my $file = $self->{plugin_dir} . '/' . $dir . '/' . $plugin_name . '.tar';
if (! -e $file) {
return $self->error('CANTLOAD', 'WARN', $file, $!);
}
my $tar = GT::Tar->open( $file ) or return $self->error('CANTLOAD', 'WARN', $file, "Unable to parse tar file: $GT::Tar::error");
return $tar;
}
sub _load_plugin_install {
# ----------------------------------------------------------------
# Takes a .tar file, looks for an Install.pm file, evals it, and
# returns a hash of meta info.
#
my ($self, $tar, $plugin_name) = @_;
my $install = $tar->get_file('Install.pm') or return $self->error('CANTLOAD', 'WARN', $plugin_name, "No Install.pm file found in tar!");
# Eval the install file.
my $file = $install->body_as_string;
{
local ($@, $SIG{__DIE__}, $^W);
eval "$file";
if ($@) {
return $self->error('CANTLOAD', 'WARN', $plugin_name, "Install.pm does not compile: $@");
}
}
# Load the meta info.
no strict 'refs';
my $plugin_pkg = $self->{prefix} . $plugin_name;
$plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0;
my $version = ${$plugin_pkg . "::VERSION"};
my $meta = defined ${$plugin_pkg . '::META'} ? ${$plugin_pkg . '::META'} : {};
if (! defined $version) {
$version = defined $meta->{version} ? $meta->{version} : 'UNKNOWN';
}
my $author = defined $meta->{author} ? $meta->{author} : 'Unknown';
my $url = defined $meta->{url} ? $meta->{url} : 'Unknown';
my $desc = defined $meta->{description} ? $meta->{description} : 'None';
return { name => $plugin_name, meta => $meta, author => $author, url => $url, description => $desc, version => $version };
}
sub _syntax_check {
# -------------------------------------------------------------------
# Returns the output of syntax checking the current file.
#
my $self = shift;
my $file = shift;
my $results;
require GT::TempFile;
if ($self->{path_to_perl} and -x $self->{path_to_perl}) {
my $tmp_file = new GT::TempFile;
open (TMPFILE, "> $$tmp_file") or return "Couldn't open temp file: $$tmp_file ($!)";
print TMPFILE $file->body_as_string;
close TMPFILE;
my $args = $self->{perl_args} || '';
# We are not really running under mod_perl in the spawned perl check.
# DBI will not load if it thinks we are (but aren't).
local($ENV{GATEWAY_INTERFACE}, $ENV{MOD_PERL});
my $perl_results = `$self->{path_to_perl} $args $$tmp_file 2>&1`;
my $filename = $file->name;
$perl_results =~ s/$$tmp_file/$filename/g;
$results = "Perl Said:
$perl_results ";
}
else {
$results = "Unable to execute perl: $self->{path_to_perl}";
}
return $results;
}
1;
|