Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
Problems? Is your data what you think it is?
 
PerlMonks  

Serving many tarballs as part of your web space

by merlyn (Sage)
on Jan 11, 2002 at 08:50 UTC ( #137936=sourcecode: print w/ replies, xml ) Need Help??

Category: Web
Author/Contact Info Randal L. Schwartz
Description: Inspired by "Serving tarball contents as part of your webspace (impractical but fun), I wrote one of my own, for a column, of course! Code is here... the text to the column will be online in a few months.
update: The column is now online.
#!/usr/bin/perl -w
use strict;
$|++;

use CGI::Carp qw(fatalsToBrowser); # DEBUG only

## begin config
my $DIR = "/home/merlyn/Web/Tarserver";
sub VALID {
  local $_ = shift;
  /(\.tgz|\.tar(\.gz)?)\z/ && !/\A\./;
}
## end config

use CGI qw(:all);

(my $path = path_info()) =~ s/\A\///;
my @path = split '/', $path;

my @choices;

if (@path) {                    # first element must be tar.gz
  die "bad tar name: $path[0]" unless VALID($path[0]);
  my $tarchive = "$DIR/$path[0]";
  die "missing tarchive: $tarchive" unless -f $tarchive and -r $tarchi
+ve;

  ## must look in contents now
  my @names = do {
    require Cache::FileCache;

    my $cache = Cache::FileCache->new
      ({namespace => 'tarserver',
        username => 'nobody',
        default_expires_in => '10 minutes',
        auto_purge_interval => '1 hour',
       }) or die "Cannot connect to cache";
    if (my $names = $cache->get($tarchive)) {
      @$names;
    } else {
      require Archive::Tar;

      die "Cannot list archive $tarchive"
        unless my @n = Archive::Tar->list_archive($tarchive);
      $cache->set($tarchive, \@n);
      @n;
    }
  };
  
  for my $step (1..$#path) {
    @names = map /\A\/?\Q$path[$step]\E(?:\/(.*))?\z/s, @names;
    die "no such name" unless @names;
    if (grep !defined $_, @names) {
      die "trailing stuff after name" if $step != $#path;
      require Archive::Tar;

      my $at = Archive::Tar->new($tarchive)
        or die "Cannot open archive $tarchive";
      my $file = join "/", @path[1..$#path];
      defined(my $contents = $at->get_content($file))
        or die "Cannot get $file from $tarchive";
  
      require File::MMagic;
      my $mimetype = File::MMagic->new->checktype_contents($contents);
      print header($mimetype), $contents;
      exit 0;
    }
  }
  
  {
    my %choices = ();
    $choices{$_}++ for map /\A([^\/]+\/?)/, @names;

    @choices = sort keys %choices;
  }

} else {                        # choose a top-level item
  opendir D, $DIR;
  @choices = sort grep VALID($_), readdir D;
  closedir D;
}

print header('text/html'), start_html('tar server'), h1('tar server');

## show path
print "from ", a({href => url()}, "Top");
{
  my $link = "";
  for (@path) {
    $link .= "/$_";
    print " / ", a({href => url().$link}, escapeHTML("$_"));
  }
}
print br;

## show sublinks
my $prefix = @path ? join("/", @path, "") : "";
print ul(map {
  li(a({href => url()."/$prefix$_"}, escapeHTML($_)));
} @choices);
  
print end_html;

Comment on Serving many tarballs as part of your web space
Download Code
Re: Serving many tarballs as part of your web space
by Aristotle (Chancellor) on Jan 11, 2002 at 09:36 UTC
    I had the hardest time trying to understand the goings-on in this part of the script:
    for my $step (1..$#path) { @names = map /\A\/?\Q$path[$step]\E(?:\/(.*))?\z/s, @names; die "no such name" unless @names; if (grep !defined $_, @names) {
    I'm quite impressed.

    Thanks for carving something useful out of my block of marble.
      The code I write for columns has far too few comments, because the comments are provided in the accompanying text. I think you'll see that it makes sense once you see the narrative I wrote for that particularly odd piece of code. I think I was trying to hard to be line-wise efficient.

      -- Randal L. Schwartz, Perl hacker

        Figured so.

        After sleeping over it, I'm wondering if there's any particular reason you didn't something along the following lines?

        my ($prefix, $filepath) = split '/', $path, 2; # ... @names = grep m!\A/?\Q$filepath\E(?:/.*)?\z!s, @names; if(@names == 1) { require Archive::Tar; # ... exit 0 } { my %choices = (); # ...

        The sole really significant difference I can see is that it doesn't catch the "trailing stuff after name" case. Am I missing something?

        Or should I just be patient and wait for the column? :-)

      I'd imagine the map is the only part that is really confusing; here it is in a nutshell:

      @names = map ( # start map / # start matching regex # this will place what is matched in the grouping # into $_, or undef if there are no matches \A # match start, kinda like ^, # except will ONLY match begining \/ ? # 0 or 1 literal backslashes \Q # start regex quotemeta $path[$step] # interpolated, and then quotemeta'd \E # end regex quotemeta (?: # non grouping parenthesis \/ # literal backslash (.*) # here is what actually is grouped; # matches the rest of the line )? # end non-grouping parens, 0 or 1 of those \z # match end, kinda like $, # except will ONLY match very end of string /sx # s lets . match newlines; i added the x , @names); # i added parenthesis

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://137936]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (4)
As of 2014-04-19 21:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (483 votes), past polls