http://qs321.pair.com?node_id=60797
Category: CGI Programming
Author/Contact Info Soren Andersen
Description:

Need to install Perl Modules Using FTP Without Having Shell Access?

This script does it for me. My provider has only `tar' on the PATH (no other usual binutils, like `gzip'), so I upload a tarball (not gzipped) to a special dir on my server. Then I go and manually enter a url with a query string like

http://yourserver/cgi-bin/rBuild.pl?archive=Text-Autoformat-1_02.tar
and there it goes. I get no interesting display back in the browser (yet*) but a "journal" page is created with a log of what happened for that module installation.

THIS IS A HUGE POTENTIAL SECURITY RISK.

Anyone messing around with this code is asking to get burned if they don't take the time to study, ask questions of senior monks (Merlyn ;-) and develop understanding of what issues my poor code has left unaddressed. Come up with more secure code if you survey this offering and find it wanting. I post for discussion, not adulation. Nor do I claim that this will work satisfactorily for anyone other than myself -- although I have a hunch it might.

This system requires you to also install `pmake' (Nick Ing-Simmons, CPAN) and the accompanying library "<CITE>Make.pm</CITE>" to your server manually first. And a module called "<CITE>Tie::STDERR</CITE>" which is another thing that is just about the coolest invention since sliced bread. And it most likely requires other things that this first write-up is going to overlook (humble apologies if so).

Soren
P.S.: I have, since posting, worked further on this application a lot and it now uses a client-pull META tag in the head to automatically take the admin-user to the "journal" (build log) page. See below in the head of the script code itself for a link to a url to see the latest version of <CITE>rBuild</CITE>.

2001-03-03 Edit by Corion : Changed mixup of PRE and CODE tags

 

#!/usr/local/bin/perl

#  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#  "rBuild", a Perl application for remote installation of
#  user-filesystem-level Perl modules on WWW servers.
#      l/m:  Sunday, February 25, 2001 3:52 PM
# The latest version of this program may be found <A HREF="http://www.
+wonderstorm.com/techstuff/rBuild.html">here</A>.
#  Copyright (c) 2001 Soren Andersen, All Rights Reserved.
#
# This script is Free Software, and may be freely redistributed or
# modified as defined in the Perl Artistic License. NO WARRENTY
# WHATSOEVER is given, neither express nor implied, not even a claim
# of merchandisability or fitness for a particular purpose. The USER
# of this software is ENTIRELY responsible for any damage it may do.
#  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

BEGIN {
 use vars qw/$start_Dir $toErrIsGiven $tmpDir $uplDir $hEADr/;
  if ($ENV{'DOCUMENT_ROOT'})  {
   $toErrIsGiven = $ENV{'DOCUMENT_ROOT'};
   $toErrIsGiven .= qq[/logs/remoteMake_log];
   $start_Dir = ($^O =~/mswin32/i)?  `cd`:`pwd`;
   chomp $start_Dir;
   require "$start_Dir/../lmods/Tie/STDERR.pm";
   import Tie::STDERR ">> $toErrIsGiven";
   open(LOG, ">>$toErrIsGiven") or
       die("Unable to open Error log \"$toErrIsGiven\": $!\n");
   require "$start_Dir/../lmods/File/PathConvert.pm";
   import File::PathConvert qw{realpath rel2abs joinpath};
   $tmpDir = $ENV{'DOCUMENT_ROOT'}. q[/secure/tmp];
   $uplDir = $ENV{'DOCUMENT_ROOT'}. q[/secure/tmp/upL];
   $hEADr  = qq[Content-type:   text/plain\n\n];
   $ENV{PATH} = ".:$ENV{PATH}";
   $^W = 0;
 } else {
   require "Tie/STDERR.pm";
   import Tie::STDERR '| D:\\cygwin\\bin\\less';
   require "File/PathConvert.pm";
   import File::PathConvert qw{realpath rel2abs joinpath};
   $start_Dir = $ENV{TMP};
   $tmpDir    = $ENV{TMP};
   $uplDir    = q[F:/temp/inst];
   $hEADr  = qq[\n Running local test:   $0\n\n];
   $^W = 1;
 }
   select STDERR;
   $|++;
   select STDOUT;
   $|++;
}

my $rel_libloc = ($start_Dir =~m@/cgi\-bin$@)?
         '../lmods' : $ENV{'DOCUMENT_ROOT'}.'/lmods';

use lib realpath("$start_Dir/../lmods");
use File::Basename;
use strict;
use vars qw{ $Source_Archive @StepWise @MMr @Make_Msgs $nl };
use subs qw{ UnDOS };

my $fontSize = ( $ENV{HTTP_USER_AGENT} and
     $ENV{HTTP_USER_AGENT} =~m@\Q] (@ )?
            'small' : 'x-small';
print $hEADr;

my %ArgUh;
  foreach my $item (split(/&/,$ENV{QUERY_STRING}))  {
     my ($name,$value) = split(/=/,$item,2);
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
     $ArgUh{$name} = $value;
  }

($Source_Archive = $ArgUh{'archive'}) or die $!;
my $blog = $start_Dir .q[/../lmods/buildjournal/].
     substr( $Source_Archive,0, rindex($Source_Archive, q[.]) ).
        q[.html];
open JOURNAL,qq[> $blog] or die 
      qq[We could not open an HTML "journal file" named "$blog"].
      qq[ to write to: $!];

$Source_Archive =  $uplDir .q[/]. $Source_Archive;
my $just_distn  = substr( $ArgUh{'archive'},0,
              rindex($ArgUh{'archive'},q[.]));

print JOURNAL<<THERE;

<HTML>
<HEAD>
<STYLE TYPE="text/css">
PRE   { font-family: verdana,"avant-garde",helvetica,arial,sans-serif;
        font-size: $fontSize;
 }
CODE  { font-family: "Lucida Console","Andale Mono",
"Courier Web","Courier New",mono;
        font-size: $fontSize;
 }
</STYLE>
</HEAD>
<BODY>
<H1>Build record for $just_distn</H1>
<H3>\@INC contains:</H3><BLOCKQUOTE>

THERE

print JOURNAL join qq[\n&lt;BR&gt;\n], @INC,
       qq[&lt;/BLOCKQUOTE&gt;&lt;/CODE&gt;\n&lt;HR&gt;\n];

my $make_target  = ($ArgUh{'target'})?
   [ $ArgUh{'target'} ] : [ 'test','pure_install' ];
@StepWise = @$make_target;
$nl = "\n";
my $abs_libloc = rel2abs( $rel_libloc,$start_Dir );
$ENV{PERL5LIB} = qq[$abs_libloc:]. $ENV{PERL5LIB};
my $tar_exe = ($ENV{'DOCUMENT_ROOT'})? q[tar] :
                             q[D:\\Cygwin\\bin\\tar.exe];
my $perl_exe = UnDOS($^X);
my $tar_cmd = q[xf];
my $makeMakefile_cmd = qq[Makefile.PL LIB=$abs_libloc ].
    qq[INSTALLMAN1DIR=$abs_libloc/man/man1 ].
    qq[INSTALLMAN3DIR=$abs_libloc/man/man3];
my $make_exe = "$start_Dir/pmake";

my $distdir = $tmpDir .q[/]. basename( $Source_Archive ); 
   $distdir = substr( $distdir,0,
                rindex($distdir,'.') );
      
 unless ($ArgUh{'target'} and (
       $ArgUh{'target'} eq 'clean' or
       $ArgUh{'target'} =~/dist/))     {
 (system( $tar_exe, $tar_cmd, $Source_Archive,
                      qq[-C], ReadiP($tmpDir))) and
              die "tarball unrolling failed:  $!";
   print JOURNAL qq[\n The distro dir just created by ],
              qq[<CITE>tar</CITE> is: $distdir\n];
   chdir $distdir or die $!;
#  HERE THE making of the Makefile HAPPENS
   @MMr = `$perl_exe -I$abs_libloc $makeMakefile_cmd`;
 } else {
   chdir $distdir or die qq[\nUnable to get into \$distdir ],
            qq["$distdir":\n$!];
 }

my ($rtv, $cmm); $rtv = 0;                # vvvvv
      while (($cmm=shift @StepWise) and defined($rtv))   {
          $rtv = open (PIPE, "$make_exe $cmm 2>&1 |");
             if (defined $rtv)                    {
                push @Make_Msgs, qq[\n\nIn process $rtv, ].
                   qq[got these messages back:\n\n];
              foreach my $proc_line (<PIPE>)        {
                  push @Make_Msgs, $proc_line;
              }
             } else {
                  warn qq[\nWhoa, we have not got a process going ],
                  qq[to get the pmake invocations working: $?];
             }
          close( PIPE );
      }

print LOG qq[\nDone. Here is the make-Makefile log:\n],
      $nl,'-' x 50,$nl, @MMr;

print JOURNAL $nl,
      '</PRE><HR><P>Done. Here is the make-Makefile log:</P><PRE>',
              $nl;
print JOURNAL @MMr;
print LOG     $nl,'-' x 50,$nl,@Make_Msgs;
print JOURNAL $nl,'</PRE><HR><P>Here is the ',
'output from the make command sequence:<PRE>',$nl;
print JOURNAL @Make_Msgs;
print JOURNAL "</PRE><HR></BODY></HTML>\n";

print qq[\nDone\n];
close LOG;
exit 0;


sub UnDOS  {

 my $revslashed = shift;
    $revslashed =~s@\\@/@g;
 return $revslashed;
}

#  THIS IS JUST FOR LOCAL TESTING
sub ReadiP  {

my $conversion;
my $inpath = UnDOS(shift);
 if ( $ENV{OS} and $ENV{OS} =~m@Windows@i ) {
     chomp($conversion = `D:\\cygwin\\bin\\cygpath -pau $inpath`);
     return $conversion;
 }
  return $inpath;
}


__END__

Back to Code Catacombs