PerlHoo, Part II - Webreference.com

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 }

Whitepapers and eBooks

Intel Whitepaper: 2010 Intel Core vPro Processors Overview
Article: Adobe Helps PHP Developers Create Rich Internet Applications
Article: Reduce Your Infrastructure Costs with Microsoft System Center
Intel Brief: Five-Star IT Support--Intel Core 2 processor with vPro Delivers ROI of 524 Percent
Article: Security Enhancements Abound in Windows Server 2008
Intel Whitepaper: Implementing Intel vPro Technology to Drive Down Client Management Costs
Microsoft Whitepaper: Improve Communications and Collaboration

Intel Article: Intel Core i5 vPro Brings Intelligence to the Processor
Microsoft Personalized Whitepapers and Resources for You
Microsoft Articles: Visual Studio 2010
Adobe Article: Java Developers Finding a Home at Adobe Flex
Microsoft Whitepaper: Make Better Decisions - SQL Server 2008 Business Intelligence.
MORE WHITEPAPERS, EBOOKS, AND ARTICLES

Webcasts

Downloads and eKits

Tutorials and Demos

home / experts / perl / tutorial / 3

home / experts / perl / tutorial / 3

Whitepapers and eBooks

Webcasts

Downloads and eKits

Tutorials and Demos