Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

webls

by jpj (Novice)
on Sep 28, 2002 at 14:00 UTC ( #201440=sourcecode: print w/replies, xml ) Need Help??
Category: Web Stuff
Author/Contact Info pvenezia at jpj dot net
Description:

This script is designed to be run from /perl or /cgi-bin on an Apache webserver. Given a root directory, it will create dynamic pages based on the contents of the directory that's referenced. As it navigates the directory hierarchy via user choices, it determines if it's already created a page for that dir, and creates a cache page in that directory, pushing the cached page to the next request unless the directory contents changes, when it will regenerate the cache page.

In short, it gets faster the more it's used.

Enhanced data display for MP3 files via MP3::Info

Examples can be seen here. Project page is here.

Comments, criticism welcome. This is one of my first "real" perl scripts.

-JPJ

#!/usr/bin/perl 

use CGI qw/:standard *table start_ul/;
use File::Basename;
use MP3::Info;
use Fcntl ':mode';


undef  @PATTERN;
undef  @FILEPATTERN;
undef  @HEADERS;
undef  @DETAILS;    
undef  $cwd;
undef $debug;

$version = "0.7";            # Version string


#---------------------------------------------------------
#       Configuration
#---------------------------------------------------------


$title = "groove.jpj.net resources";    # Page title
$tbbgcolor = "#C0C0C0";                # Title bar background
$tbfcolor = "black";                # Title bar text
$bgcolor = "#cccccc";               # Table item background
$fcolor = "black";                  # Table text
$icondir = "/icons/small";        # Apache Icons directory

$indexfile = ".pindex.html";               # Cache file name
$notesfile = ".pnotes.txt";             # Notes file name
#$debug = "1";                # Turn on debugging

    
#-----------------------------------------------------------
#    Error msg sub
#-----------------------------------------------------------

sub error_msg {
    print header,
        start_html("Action Denied"),
        h1("Action Denied"),
        h3("$_[0]"),
        h3(a{href=>"$script_url"},"Return"),
        end_html;
        exit;
}

#-----------------------------------------------------------
#    Get stats on files in $cwd
#-----------------------------------------------------------
sub getfiles {

    undef $htype;
    undef $size;
    undef $date;
    undef $link;
    undef $icon;
    undef $typename;
    undef $file;
    

foreach  $file (<@PATTERN>) {
        #next if ($file =~ /(index.html|notes.txt)/);
        next if ($file =~ /($indexfile|$notesfile)/);
    
     ($type, $size, $sec) = (stat($file)) [2,7,9];

    if (S_ISDIR($type)) {  $typename = "Directory";  $icon = "$icondir
+/dir.png"; }
    if (S_ISREG($type)) {  $typename = "File";  $icon = "$icondir/unkn
+own.gif"; }
     if (S_ISLNK($type)) {  $typename = "Link";  $icon = "$icondir/lin
+k.png"; }
    $icon = "$icondir/sound2.gif" if ($file =~ /\.wav/);
    $icon = "$icondir/image2.gif" if ($file =~ /\.(bmp|jpg|gif|png)/i)
+;
    $icon = "$icondir/compressed.gif" if ($file =~ /\.(gz|tar|zip|bz|r
+pm|sit|sea|hqx)/i);
    $icon = "$icondir/text.gif" if ($file =~ /\.(txt|pl|sh)/i);
    $icon = "$icondir/movie.gif" if ($file =~ /\.(mov|avi|wmf|fli|asf)
+/i);
    $icon = "$icondir/index.gif" if ($file =~ /\.(html)/i);

#-----------------------------------------------------------
#    Call MP3::Info if file is an MP3
#-----------------------------------------------------------
        if ($file =~ /\.mp3$/) {
                 $info = new MP3::Info $file;;
                ($length, $bitrate) = split (" ", sprintf "%s %s", $in
+fo->TIME, $info->BITRATE);
        $icon = "$icondir/sound2.gif";
        $htype = "Length/Type";
        $typename = "$length\m - $bitrate\kbps";    
        
        }

     $date = (localtime($sec));

#--------------------------------------------------------------
#    Do type/size calc
#--------------------------------------------------------------
    if (S_ISDIR($type)) {
         $psize = "--";
    }
    elsif ($size < 1024 ) {
         $psize = "$size bytes" 
    }
    elsif ($size < 1024000 ) {
         $psize = sprintf "%.1f kb", $size / 1024;
    }
    else {
         $psize = sprintf "%.2f MB", $size / 1024 / 1024;
    }
    
     $name = basename $file;

     $link = "/pub/$cwd/$name";
     $link =~ s/\/\//\//g;
#--------------------------------------------------------------
#    Push data for files list table into @DETAILS
#--------------------------------------------------------------
        if (S_ISDIR($type)) {
            push (@DETAILS,a({href=>"$script_url?page=$cwd/$name"},img
+({-border=>undef,src=>$icon}),"$name"), $psize, $date, "$typename<tr>
+");
            }
        elsif (S_ISREG($type)) {
            push (@DETAILS,a({href=>"$link"},img({-border=>undef,src=>
+$icon}),"$name"), "$psize", "$date", "$typename<tr>");
    
        }
        
    }
            $htype = "Type" unless ($htype);
            push (@HEADERS, qw(Name Size Date), $htype);
} # End getfiles sub


#--------------------------------------------------------------
#    Get parameters passed from URL, seed 
#       "Previous Directory" link.
#--------------------------------------------------------------

sub getparams {
    if (param('page')) {
        $cwd = param('page');
        &error_msg("Illegal Path: $cwd") if ($cwd =~ /\.\./);
        undef $cwd if ($cwd =~ /(\.|\/)$/);
        $dirname = basename $PATH;
        $precwd = dirname $cwd; # unless ($precwd =~ /\.$/);

    push (@DETAILS,a({href=>"$script_url?page=$precwd"},img({-border=>
+undef,src=>"$icondir/back.gif"}),"Previous Directory"),"","","<tr>") 
+unless (! $cwd);

    }

    else {
        $cwd = "";
        $is_index = "1";
        $dirname = $PATH;
    }
    $url = "$url/$cwd";
    $PATH = "$PATH/$cwd";

        &error_msg("Illegal Path: $cwd") if (! -d PATH);    # Bail if 
+$PATH doesn't exist

    @PATTERN="$PATH/$FILEPATTERN";            # Files list pattern mat
+ch
    $script_url = url(-relative=>1);    # Pull relative URL into $scri
+pt_url

}    # getparams

#--------------------------------------------------------------
#      Start script, pass static `.pindex.html` page
#       through if no changes to dir mtime, or call
#       getfiles, write_html to create page and store in
#       .pindex.html
#--------------------------------------------------------------

    &getparams;                 # Seed parameters

$weblsindex = "$PATH/$indexfile";


if ( -f $weblsindex ) {
    ($pubmtime) = (stat($weblsindex)) [10];
    ($pathmtime) = (stat($PATH)) [10];

    if ( $pathmtime le $pubmtime ) {
    
                        open (PUBLSINDEX, "<$weblsindex");
                        print <PUBLSINDEX>;
                print "\nDEBUG\n$weblsindex\n" if ($debug);
                print "$pubmtime, $pathmtime\n" if ($debug);
                        close (PUBLSINDEX);
            exit;
    }
}

    &getfiles;
    &write_html;

            print small,(" (created)") if ($debug);

            print "\nDEBUG\n$weblsindex\n" if ($debug);
                        print "$pubmtime, $pathmtime\n" if ($debug);


    local *STDOUT;
    open (STDOUT, ">$weblsindex");
    &write_html();
    print small,(" (cached)");
    close (STDOUT);

#-------------------------------------------------------------
#    write_html sub to create page
#-------------------------------------------------------------

sub write_html () {

print header,
    start_html("$title - $cwd"),
    h1("<center>$title</center>");

#-------------------------------------------------------------
#    Generate linked path        
#-------------------------------------------------------------

    unless (! $cwd) { 
        undef  $refcwd;
        undef  $pwd;
        undef  @TAGCWD;
        $pwd = basename $cwd;
        push(@TAGCWD, a({href=>"$script_url"},"<h3><CENTER>/"));

        while ($cwd =~ /\G\/?([0-9A-Za-z'.-]+)/g) {
                        $prelink = $1;
            $refcwd = "$refcwd/$1";
    
            if (! ($1 =~ /$pwd$/)) { 
                push(@TAGCWD, a({href=>"$script_url?page=$refcwd"}, $p
+relink), "/");
            }
            else {
                push(@TAGCWD, $pwd, "/");
            }
        }
        
    print @TAGCWD[0..$#TAGCWD];
    print "</H3></CENTER>";

    }    

#-------------------------------------------------------------
#    Build file list table with data from getfiles sub
#-------------------------------------------------------------
    print hr,
    table({-align=>"center",-width=>"70%",-border=>"0"}),
        Tr({-align=>"LEFT",-valign=>"TOP",-bgcolor=>$tbbgcolor,-fontco
+lor=>$tbfcolor},
        [th(\@HEADERS),td({-bgcolor=>$bgcolor},\@DETAILS)]);
    print end_table();

        if ( -f "$PATH/$notesfile" ) {
            open (NOTES, "<$PATH/$notesfile") || next;
            undef $/;
            $notes = <NOTES>;
            $/ = "\n";
            
            print table({-align=>"center",-width=>"70%",-border=>"0"})
+,
            Tr({-align=>"LEFT",-valign=>"TOP"},[td(h3("Notes")),td($no
+tes)]);
            print end_table();
            close (NOTES);
        }

        
          print hr,
        em,small("Generated by webls.pl v$version"),
        end_html();
}
Replies are listed 'Best First'.
Re: webls
by Aristotle (Chancellor) on Sep 28, 2002 at 18:30 UTC

    No strict, no warnings - even though you're "declaring" your variables with undef. my would have been shorter and better practice..

    Also, rather than hardcoding the HTML generation into the code all over the place I'd rather create a list of hashes with info on each file, then churn that through a template for one of the many existing modules for the job - much cleaner and tons more flexible. A small layout change won't require someone to go digging deep inside the script's logic to find where that piece of output gets generated.

    Makeshifts last the longest.

      Completely agreed... I tried to keep the HTML generation as compact as possible, but found that without the occasional <tr> tag, it wouldn't display correctly on IE. Ideally, I'd like to have the tables built from hashes, with column headers built from the keys, permitting more dynamic table generation, plus the ability to sort the output based on user prefs.

      Very much a work in progress... -JPJ

Re: webls
by zentara (Archbishop) on Sep 28, 2002 at 15:12 UTC
    Hi, I'm using the latest Mozilla browser, and when I click on your example link, I get "you have chosen to download a file of type: application/x-perl from http://groove.jpj.net/perl". Same thing for your Projects link. Is my browser screwed up, or what?

      Or maybe not. With CGI::Pretty instead of CGI, performance of the server was drastically reduced. With CGI, stating a directory of 1440 items takes ~3s to display in a browser, minimal impact on the server, but simply changing to CGI::Pretty caused the process to exhaust all resources on the server stating the same directory.

      Can someone educate me on why this might be?

      Also, if the script exists in /perl and has a .pl extension, some Mozilla based browsers display the HTML code, but not the page (only for the cached pages) while all other browsers are fine, including other versions of Mozilla. If the script has a .cgi or no extension, all is well. I'm not quite sure what to make of that.

      -JPJ

      Hrm. I'm using Mozilla 1.0.1 on Linux and everything works fine. I've tested with IE5/6 (Windoze/MacOS X), and Opera and had no issues. I see by looking at my server logs that others don't seem to be having issues. Try a screenshot -JPJ
      Looks like it might be a bug in Mozilla 1.1 WRT long lines.

      Changing  use CGI qw/:standard *table start_ul/; to  use CGI::Pretty qw/:standard *table start_ul/; seems to have fixed that issue on Mozilla 1.1, without adversely affecting other browsers.

      {sigh}

      -JPJ

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (6)
As of 2019-12-07 11:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Strict and warnings: which comes first?



    Results (160 votes). Check out past polls.

    Notices?