Close
1 #!/usr/bin/perl -w 2 3 # phadmin.pl - builds a Yahoo like Web directory 4 # by Jonathan Eisenzopf. v1.0 19990629 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 https://www.webreference.com 22 # Contact [email protected] 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/perlhoo'; 33 my $baseurl = '/cgi-bin/phadmin.pl'; 34 my $new_datafile = 'perlhoo_new.csv'; 35 36 # Main 37 my $query = new CGI; 38 print $query->header; 39 40 # get relative directory from URL 41 my $reldir = $query->path_info; 42 43 # strip of leading and trailing / 44 $reldir =~ s/^\/+//; 45 $reldir =~ s/\/+$//; 46 47 # get directory based on $rootdir and $reldir 48 my $dir = $reldir =~ /\S+/ ? "$rootdir/$reldir" : ($rootdir); 49 50 # Main code body 51 if ($query->param('action') eq 'add') { 52 &print_header; 53 &add_link($dir); 54 &list_categories($dir); 55 &print_footer; 56 } elsif ($query->param('action') eq 'edit') { 57 &edit_link($dir); 58 } elsif ($query->param('action') eq 'delete') { 59 &print_header; 60 &delete_link($dir,$query->param('url'),$query->param('type')); 61 &list_categories($dir); 62 &print_footer; 63 } else { 64 &print_header; 65 &list_categories($dir); 66 &print_footer; 67 } 68 69 # Subroutines 70 sub add_link { 71 my $dir = shift; 72 73 # delete link from $new_datafile if type is new 74 &delete_link($dir,$query->param('url'),1) if ($query->param('type') eq 'new'); 75 76 # delete link from $datafile if it exists 77 &delete_link($dir,$query->param('url')); 78 79 # lock semaphore file 80 open(SEM, "> $dir/$datafile.semaphore") || die "Cannot open $dir/$datafile.semaphore for write: $!"; 81 flock(SEM, 2) || die "Cannot get exclusive lock for $dir/$datafile.semaphore: $!"; 82 83 # open $datafile 84 open(FILE, ">> $dir/$datafile") || die "Cannot open $dir/$datafile for write: $!"; 85 86 # append record to $datafile 87 my $csv = Text::CSV_XS->new(); 88 print FILE $csv->string,"\n" 89 if $csv->combine($query->param('url'),$query->param('title'),$query->param('description'),$query->param('name'),$query->param('email')); 90 91 # close all filehandles 92 close(FILE); 93 close(SEM); 94 unlink "$dir/$datafile.semaphore"; 95 } 96 97 sub delete_link { 98 my ($dir,$url,$new) = @_; 99 my $foundit = 0; # set to 1 if we find the url 100 101 # do we want to modify $datafile or $new_datafile 102 my $file = ($new) ? "$new_datafile" 103 : "$datafile"; 104 105 # if the file doesn't exist, simply exit 106 return unless -e "$dir/$file"; 107 108 # open data file 109 open(IN, "$dir/$file") || die "Cannot open $dir/$file for read: $!"; 110 111 # open temp file 112 open(OUT, "> $dir/$file.$$") || die "Cannot open $dir/$file.$$ for write: $!"; 113 114 # loop over the data file, looking for $url 115 while (<IN>) { 116 if (/$url/) { # skip the line if it contains the url 117 $foundit=1; 118 } else { 119 print OUT; # print to the temp file 120 } 121 } 122 close(IN); 123 close(OUT); 124 125 # if we found the url, we need to move the tmp file to production 126 if ($foundit > 0) { 127 # lock semaphore file 128 open(SEM, "> $dir/$file.semaphore") || die "Cannot open $dir/$file.semaphore for write: $!"; 129 flock(SEM, 2) || die "Cannot get exclusive lock for $dir/$file.semaphore: $!"; 130 131 # move the tmp file to production 132 rename "$dir/$file.$$","$dir/$file"; 133 close(SEM); 134 unlink "$dir/$file.semaphore"; 135 136 # otherwise, just delete the tmp file 137 } else { 138 unlink "$dir/$file.$$"; 139 } 140 } 141 142 sub edit_link { 143 my $dir = shift; 144 my $url = $query->param('url'); 145 my ($title,$description,$name,$email); 146 &print_header; 147 my $file = ($query->param('type') eq 'new') ? "$new_datafile" 148 : "$datafile"; 149 my $entries = &retreive_entries("$dir/$file"); 150 151 foreach my $entry (@$entries) { 152 if ($entry->[0] eq $url) { 153 $title = $entry->[1]; 154 $description = $entry->[2]; 155 $name = $entry->[3]; 156 $email = $entry->[4]; 157 } 158 } 159 160 print <<HTML; 161 <TABLE BORDER=0 CELLSPACING=1 CELLPADDING=2 BGCOLOR="#FFED9A"> 162 <FORM METHOD=POST ACTION="$baseurl/$reldir"> 163 <input type=hidden name=action value="add"> 164 HTML 165 166 print '<input type=hidden name=type value="new">' if $query->param('type') eq 'new'; 167 print <<HTML; 168 <tr BGCOLOR="#FFCC00"> 169 <th COLSPAN=2><FONT size=+2 face="Arial,Helvetica">PerlHoo Entry</font></th> 170 </tr> 171 <tr><th BGCOLOR="#FFCC00" align=right>URL</th> 172 <td><input name="url" size=60 value="$url"></td></tr> 173 174 <tr><th BGCOLOR="#FFCC00" align=right>Title</th> 175 <td><input name="title" size=60 value="$title"></td></tr> 176 177 <tr><th BGCOLOR="#FFCC00" align=right>Description</th> 178 <td><textarea name="description" rows="3" cols="60">$description</textarea></td></tr> 179 180 <tr><th BGCOLOR="#FFCC00" align=right>Submitter</th> 181 <td><input name="name" size=60 value="$name"></td></tr> 182 183 <tr><th BGCOLOR="#FFCC00" align=right>Email</th> 184 <td><input name="email" size=60 value="$email"></td></tr> 185 <tr BGCOLOR="#FFCC00"><td><input type=submit value=" Save Entry "></form></td> 186 </tr></table> 187 HTML 188 &print_footer; 189 } 190 191 sub list_categories { 192 my $dir = shift; 193 my $reldir = $dir; 194 $reldir =~ s#$rootdir/?##; 195 my @parts = split(/\//,$reldir); 196 197 my $category = "<a href=\"$baseurl\">Home</a>"; 198 for (my $i=0; $i < @parts; $i++) { 199 $category .= ": <a href=\"$baseurl/"; 200 $category .= join('/',@parts[0..$i]); 201 $category .= "\">$parts[$i]</a>"; 202 } 203 204 print '<table border="0" width="100%" cellpadding="1" cols="4" cellspacing="1" BGCOLOR="#FFED9A">'; 205 print "<tr><td colspan=\"4\" BGCOLOR=\"#FFCC00\"><B>$category</B></td></tr>\n"; 206 &print_entries("$dir/$new_datafile",$reldir,1); 207 &print_entries("$dir/$datafile",$reldir); 208 print "</table><BR>\n"; 209 210 opendir DIR,$dir || die "Cannot open $dir: $!\n"; 211 my @dirs = grep -d, map "$dir/$_", grep !/^\./, readdir DIR; 212 closedir DIR; 213 214 foreach my $dir (@dirs) { 215 &list_categories($dir); 216 } 217 } 218 219 sub print_entries { 220 my ($datafile,$reldir,$new) = @_; 221 my $entries = &retreive_entries($datafile); 222 my $url; 223 foreach my $entry (@$entries) { 224 if ($new) { 225 $url = "$baseurl/$reldir?action=edit&url=$entry->[0]&type=new"; 226 print "<tr bgcolor=\"#FF0000\">\n"; 227 } else { 228 $url = "$baseurl/$reldir?action=edit&url=$entry->[0]"; 229 print "<tr>\n"; 230 } 231 print "<td><a href=\"$url\" >$entry->[1]</a></td>\n"; 232 print "<td>$entry->[2]</td>\n"; 233 print "<td><a href=\"$entry->[0]\" target=\"_new\">$entry->[0]</a></td>\n"; 234 print "<td align=\"center\"><a href=\"$baseurl/$reldir?action=delete&url=$entry->[0]"; 235 print "&type=new" if $new; 236 print "\">Delete</a></td></tr>\n"; 237 } 238 } 239 240 sub retreive_entries { 241 my $datafile = shift; 242 my @entries = (); 243 if (-e $datafile) { 244 open(DATA,$datafile) || die "Cannot open $datafile: $!"; 245 my $csv = Text::CSV_XS->new(); 246 while (<DATA>) { 247 chomp; 248 $csv->parse($_); 249 my @columns = $csv->fields(); 250 push(@entries,\@columns); 251 } 252 } 253 return \@entries; 254 } 255 256 sub print_footer { 257 print <<HTML; 258 </body></html> 259 HTML 260 } 261 262 263 sub print_header { 264 print <<HTML; 265 <html> 266 <head><title>PerlHoo Admin</title></head> 267 <body BGCOLOR="#FFFFFF" TEXT="#000000" LINK="#0033FF" VLINK="#0033FF"> 268 <TABLE WIDTH="100%" BORDER=0 CELLSPACING=0 CELLPADDING=1> 269 <tr> 270 <td width="70%" bgcolor="#CC0000"><font face="arial,helvetica" size="+2" color=white>PerlHoo Admin</font></td> 271 <td width="30%"> 272 <TABLE WIDTH="100%" BORDER=0 CELLSPACING=0 CELLPADDING=4 BGCOLOR="#FFFFFF"><tr><td> 273 <a href="$baseurl">Home</a> | <a href="$baseurl/$reldir?action=edit">Add new site</a></td></tr> 274 </table> 275 </td> 276 </tr></table> 277 278 HTML 279 } 280
Find a programming school near you