Yahasp | 5 | WebReference

Yahasp | 5

phadmin.pl Source
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 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/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