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 align="center">
270 <td width="70%" bgcolor="#CC0000"><font face="arial,helvetica" size="+2" color=white>PerlHoo Admin</font></td>
271 <td width="30%" bgcolor="#000000">
272 <TABLE WIDTH="100%" BORDER=0 CELLSPACING=0 CELLPADDING=4 BGCOLOR="#FFFFFF"><tr><td align="center">
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
|
