Home > Articles > Web Development > Perl

  • Print
  • + Share This
From the author of

Listing

     01: #!/usr/bin/perl -wT

     02: use strict;
     03: use CGI qw(:standard);
     04: use Archive::Tar;
     05: use File::Basename;

     06: my @DIRS = qw{tars /tmp};
     07: my $SCRIPT = basename $0;
     08: my $tar;

     09: my %actions = ('list_archives' => \&list_archives,
              ''       => \&list_archives,
              'show_file'   => \&show_file,
              'show_content' => \&show_content,
              );

     10: print header;

     11: my $action = param('action');

     12: if (param('tar')) {
     13:   $tar = param('tar');
     14:   $tar =~ s!\.\.?/!!g;
     15: }

     16: if (exists $actions{$action}) {
     17:   $actions{$action}->();
     18: }else{
     19:   print qq{Sorry, '$action' isn't supported.<br>};
     20: }

     21: sub list_archives {
     22:   print h2("List of files");

     23:   for my $dir (@DIRS) {
     24:       print qq{Directory: $dir<br>\n};

     25:       opendir(DIR, $dir) or print qq{$!<p>\n} and next;

     26:       my @files = grep {/\.tar(?:\.gz)?$/} readdir(DIR);
     27:       for (@files) {
     28:           (my $short_name = $_) =~ s/\.tar.*$//;
     29:           print a({-href=>"tar.cgi?action=show_file&tar=$d
 ir/$_"},$short_name), br;
     30:       }
     31:       closedir DIR;
     32:       print p;
     33:   }
     34: }

     35: sub show_file {
     36:   print h2("Contents of $tar:");
     37:   print qq{Sorry, '$tar' does not exist.} and return unless -e $tar;

     38:   my @files = Archive::Tar->list_archive($tar);

     39:   for (@files) {
     40:       if (/\/$/) {
     41:           print qq{$_<br>\n};
     42:       }else{
     43:           print '<dd>', a({-href => "tar.cgi?action=show
 _content&file=$_&tar=$tar"}, $_), '</dd>';
     44:       }
     45:   }
     46: }

     47: sub show_content {
     48:   my $file = param('file');

     49:   my $tar_obj = Archive::Tar->new($tar);
     50:   print qq{<pre> } . $tar_obj->get_content($file) . qq{</pre>};
     51: }

     52: print p, a({-href=>$SCRIPT},"Home");
__END__

Kevin Meltzer <perlguy@perlguy.com> is a co-author of Writing CGI Applications with Perl (Addison-Wesley, 2001), web content admin for Yet Another Society, and a Software Engineer for Verio. He has been programming with Perl since 1994.

  • + Share This
  • 🔖 Save To Your Account