PerlHoo, Part II | 9

PerlHoo Source
     1   #!/usr/bin/perl -w
     2   
     3   # perlhoo.pl - builds a Yahoo like Web directory
     4   # by Jonathan Eisenzopf. v1.1 19990319
     5   # Copyright (c) 1999 internet.com LLC. All Rights Reserved.
     6   #
     7   # This program is free software; you can redistribute it and/or modify
     8   # it under the terms of the GNU General Public License as published by
     9   # the Free Software Foundation; either version 2 of the License, or
    10   # (at your option) any later version.
    11   #
    12   # This program is distributed in the hope that it will be useful,
    13   # but WITHOUT ANY WARRANTY; without even the implied warranty of
    14   # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15   # GNU General Public License for more details.
    16   #
    17   # You should have received a copy of the GNU General Public License
    18   # along with this program; if not, write to the Free Software
    19   # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    20   #
    21   # Originally published and documented at http://www.webreference.com
    22   # Contact eisen@internet.com for all other uses.
    23   
    24   # Modules
    25   use strict;
    26   use Text::CSV_XS;
    27   use CGI;
    28   use CGI::Carp qw(fatalsToBrowser);
    29   
    30   # Constants
    31   my $datafile     = 'perlhoo.csv';
    32   my $rootdir      = '/www/directory';
    33   my $baseurl      = '/cgi-bin/perlhoo.pl';
    34   my $new_datafile = 'perlhoo_new.csv';
    35   
    36   # Main
    37   my $query = new CGI;
    38   print $query->header;
    39   
    40   my $reldir = $query->path_info;
    41   $reldir =~ s/^\/+//;
    42   $reldir =~ s/\/+$//;
    43    
    44   if ($query->param('keywords') eq 'add') {
    45       if ($query->request_method eq 'GET') {
    46   	&print_add_screen($reldir);
    47       } elsif ($query->request_method eq 'POST') {
    48   	&add_link($reldir);
    49       }
    50   } else {
    51       &print_hoo($reldir);
    52   }
    53   
    54   # Subroutines
    55   sub add_link {
    56       my $reldir = shift;
    57       my $dir = "$rootdir/$reldir";
    58       $dir =~ s/\/+$//;
    59   
    60       open(FILE, ">> $dir/$new_datafile") || &error("Cannot open $dir/$new_datafile for write: $!");
    61       flock(FILE, 2) || &error("Cannot get exclusive lock for $dir/$new_datafile: $!");
    62   
    63       my $csv = Text::CSV_XS->new();
    64       print FILE $csv->string,"\n" 
    65   	if $csv->combine($query->param('url'),$query->param('title'),$query->param('description'),$query->param('name'),$query->param('email'));
    66       close(FILE);
    67   
    68       &print_header($reldir);
    69   
    70       print <<HTML;
    71   Thank you for your suggested addition to the PerlHoo <b>$reldir</b> category. 
    72   While we do review all new site suggestions, we cannot guarantee that all 
    73   submissions will be added. The following information will be sent to the 
    74   directory editor:
    75   <p>
    76   <table border="0" cellpadding="2" cellspacing="2">
    77   HTML
    78   
    79       print "<tr><td align=\"right\"><B>URL:</B></td><td>",$query->param('url'),"</td></tr>\n";
    80       print "<tr><td align=\"right\"><B>Title:</B></td><td>",$query->param('title'),"</td></tr>\n";
    81       print "<tr><td align=\"right\"><B>Description:</B></td><td>",$query->param('description'),"</td></tr>\n";
    82       print "<tr><td align=\"right\"><B>Your Name:</B></td><td>",$query->param('name'),"</td></tr>\n";
    83       print "<tr><td align=\"right\"><B>Your Email:</B></td><td>",$query->param('email'),"</td></tr></table></p>\n";
    84   
    85       print <<HTML;
    86   <p>Return to <a href="$baseurl/$reldir">$reldir</a>
    87   <hr noshade>
    88   HTML
    89   
    90       &print_footer($reldir);
    91   }
    92   
    93   sub error {
    94       my $msg = shift;
    95       print "<FONT color=\"#FF0000\"><B>$msg</B></FONT>\n";
    96       die "$msg";
    97   }
    98   
    99   sub print_add_screen {
   100       my $reldir = shift;
   101       print <<HTML;
   102   <html>
   103   <head><title>PerlHoo - $reldir - Add a Resource</title></head>
   104   <body BGCOLOR="#FFFFFF" TEXT="#000000" LINK="#0033FF" VLINK="#660099">
   105   <center><H1>PerlHoo</H1></center>
   106   <p><H3>Add a Resource to: $reldir</H3><HR noshade>
   107   <form action="$baseurl/$reldir" method="POST">
   108   <input type="hidden" name="keywords" value="add">
   109   <table border="0" cellpadding="2" cellspacing="2">
   110   <tr><td align="right"><B>URL:</B></td><td><input name="url" size="40"></td></tr>
   111   <tr><td align="right"><B>Title:</B></td><td><input name="title" size="40"></td></tr>
   112   <tr><td align="right"><B>Description:</B></td><td><textarea name="description" rows="3" cols="40"></textarea></td></tr>
   113   <tr><td align="right"><B>Your Name:</B></td><td><input name="name" size="40"></td></tr>
   114   <tr><td align="right"><B>Your Email:</B></td><td><input name="email" size="40"></td></tr>
   115   <tr><td></td><td><input type="submit" value=" Submit Resource ">
   116   <input type="reset" value=" Reset "></td></tr>
   117   </table>
   118   <HR noshade>
   119   </form></p>
   120   </html>
   121   HTML
   122   }
   123   
   124   sub print_categories {
   125       my $reldir = shift;
   126       my $dir = "$rootdir/$reldir";
   127       $dir =~ s/\/+$//;
   128   
   129       opendir DIR,$dir ||  &error("Cannot open $dir: $!");
   130       my @dirs = sort(grep -d, map "$dir/$_", grep !/^\./, readdir DIR);
   131       closedir DIR;
   132       
   133       foreach my $thisdir (@dirs) {
   134   	$thisdir =~ s/$rootdir\/$reldir//;
   135   	$thisdir =~ s/\/+$//g;
   136   	$thisdir =~ s/^\/+//g;
   137   
   138   	my $url;
   139   	if ($reldir =~ /\S+/) {
   140   	    $url = "$baseurl/$reldir/$thisdir";
   141   	} else {
   142   	    $url = "$baseurl/$thisdir";
   143   	}
   144   
   145   	my $pdir = $thisdir;
   146   	$pdir =~ s/_/ /g;
   147   	print "<li><a href=\"$url\"><B>$pdir</B></a></li>\n";
   148       }
   149       print "<HR noshade>\n";
   150   }
   151   
   152   sub print_footer {
   153       my $reldir = shift;
   154       print <<HTML;
   155   <center><a href="$baseurl">Home</a> | <a href="$baseurl/$reldir?add">Suggest new link</a></center>
   156   HTML
   157   }
   158   
   159   sub print_header {
   160       my $reldir = shift;
   161       my @parts = split(/\//,$reldir);
   162       
   163       print <<HTML;
   164   <html>
   165   <head><title>PerlHoo - $reldir</title></head>
   166   <body BGCOLOR="#FFFFFF" TEXT="#000000" LINK="#0033FF" VLINK="#660099">
   167   <center><H1>PerlHoo</H1></center>
   168   HTML
   169   
   170       print "<p><H3><a href=\"$baseurl\">Top</a>";
   171       for (my $i=0; $i < @parts; $i++) {
   172   	if ($i == (@parts - 1)) {
   173   	    my $title = $parts[$i];
   174   	    $title =~ s/_/ /g;
   175   	    print ": $parts[$i]";
   176   	} else {
   177   	    print ": <a href=\"$baseurl/";
   178   	    print join('/',@parts[0..$i]);
   179   	    print "\">$parts[$i]</a>";
   180   	}
   181       }
   182       print "</H3></p><HR noshade>\n";
   183   }
   184   
   185   sub print_hoo {
   186       my $reldir = shift;
   187       &print_header($reldir);
   188       &print_categories($reldir);
   189       &print_links("$rootdir/$reldir/$datafile");
   190       &print_footer($reldir);
   191   }
   192   
   193   sub print_links {
   194       my $datafile = shift;
   195       if (-e $datafile) {
   196   	open(DATA,$datafile) || &error("Cannot open $datafile: $!");
   197   	my $csv = Text::CSV_XS->new();
   198   	while (<DATA>) {
   199   	    chomp;
   200   	    $csv->parse($_);
   201   	    my @columns = $csv->fields();
   202   	    print "<li><a href=\"$columns[0]\">$columns[1]</a> - $columns[2]\n";
   203   	}
   204       }
   205   }

http://www.internet.com

Produced by Jonathan Eisenzopf and
Created: April 19, 1999
Revised: April 20, 1999

URL: http://www.webreference.com/perl/tutorial/3/