[13718] in Perl-Users-Digest
Perl-Users Digest, Issue: 1128 Volume: 9
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Wed Oct 20 09:10:24 1999
Date: Wed, 20 Oct 1999 06:10:11 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Message-Id: <940425011-v9-i1128@ruby.oce.orst.edu>
Content-Type: text
Perl-Users Digest Wed, 20 Oct 1999 Volume: 9 Number: 1128
Today's topics:
Request for peer review CGI, perl, images - long post. <gus_goose@hotmail.com>
Re: SGML/HTML parsing tool (Abigail)
Substitution oliver.cookYTTFIT@ukonline.co.uk
Re: Substitution <jeffp@crusoe.net>
Re: Substitution <jeffp@crusoe.net>
Re: Unix command ´tree´ in Perl? <rhomberg@ife.ee.ethz.ch>
Re: Unix command =?iso-8859-1?Q?=B4tree=B4?= in Perl? (Abigail)
Re: why doesn't my script work? <nutt@forwiss.uni-erlangen.de_antispam_>
Digest Administrivia (Last modified: 16 Sep 99) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Wed, 20 Oct 1999 13:05:51 +0100
From: gus <gus_goose@hotmail.com>
Subject: Request for peer review CGI, perl, images - long post.
Message-Id: <380DB01F.8CEC0225@hotmail.com>
I have been puting a number of perl/cgi interfaces together, but have
only recently explored more complex applications. I would consider
myself an early intermediate perl/CGI programmer.
The interface / OS / etc are:
Perl 5.005,
Linux 2.1.12
SuSE 6.2
Apache 1.3 IIRC
Clients used are Netscape 4.61 on both Win32 and Linux.
As a home project I decided to create a web based interface to a number
of "photo albums" I have. In the past I have scanned photo's to disk,
and have stored these in a number of directories of the form
"..../category/trip/film/photo". There are other directories I have
which also have images in them, but ar slightly different in structure.
To cope with all possible storage mechanisms, I created a CGI/perl
script which provides a mechanism to browse the directories (following
symlinks), and to show thumbnail images of all images in the current
directory. Each thumbnail is a hyperlink to the unmodified full image.
Since I have never had my code reviewed by any perl-literate person, I
am concerned that there are glaring irregularities, poor practices, or
simple misunderstandings in the code. It would be very useful to me if
people could comment on the following:
1. Is there a better / alternative / more standard philosophy to writing
CGI/Perl programs (particularly with functionality similar to that which
I intend to create).
2. Is there a more efficient mechanism for generating thumbnails (the
current mechanism is slow, and there are severe delays in a number of my
directories where there are 35 - 40 images each of a couple of meg).
What are the available options.
3. Does this program / idea already exist anywhere? Has someone else
done it, but better?
4. Any other comments (This is your opportunity to be a teacher ... ;-)
As a quick-start to getting it installed, create a random directory, and
change the $path variable to point at that. In that direcroty, create
symlinks to directories which contain images such as /usr/doc/packages
(there are a number of images in there) /opt/kde/share/lib/wallpapers,
and others.
Thanks in advance for any assistance.
gus
Here is the code
Thanks again
#!/usr/bin/perl -w
# This is nph-picbrowser.cgi
# Author - Gus - gus_goose@hotmail.com
# License - GPL
# Version 0.01
# *********************************
# Please e-mail any changes / enhancements directly to the author - hopefully I can collate things better
# and I want a better system myself ;-)
# *********************************
#
# This script provides a web interface to an image browser.
#
# This works on a Linux machine with the various modules installed
# as well as the programs jpgtn and cjpeg
# not tested on anything other than SuSE 6.2 linux, but should work just fine
# on any other linux.
# known bugs
# 1. performance could be better
# 2. when one directory has a name which exactly matches the beginning of another directory name
# then both directories will have an openfolder icon if either one normally would.
# eg ..../photos/jan and ..../photos/january
use CGI qw/:standard :netscape -nph/;
use CGI::Carp qw(fatalsToBrowser);
use strict;
my ($self, $title, $action, $path, $filepic, $folderpic, $folderopenpic, $thumbsize);
sub frames {
# output the relevant frameset details, This splits the screen horizontally
print header ();
# this puts $title at the top of a Netscape browser
print "<HTML>\n<HEAD>\n<TITLE>$title</TITLE>\n</HEAD>\n";
print frameset ({rows=>'14%,*',
title=>'PicBrowser',
border=>'0'}, "\n",
frame ({-name=>'heading', -src=>$self.'?action=heading'}), "\n",
frame ({-name=>'subform', -src=>$self.'?action=subform'}), "\n"
);
}
sub subformframe {
# This splits the screen vertically in the bottom frame (subform) from above
print header ();
my ($dir);
$dir=param('dir');
$dir = CGI->escape ($dir);
print frameset ({cols=>'15%,*',
border=>'1'}, "\n",
frame ({-name=>'margin', -src=>$self.'?action=margin&dir='.$dir.'#'.$dir}), "\n",
frame ({-name=>'body', -src=>$self.'?action=body&dir='.$dir})
);
}
sub headingframe {
# This creates the contents in the top frame. It is simple.
print header ();
print start_html (-bgcolor=>'white', -background => '/wallpaper/gray2.jpg');
print center (h1 ($title));
print end_html ()
}
sub dirlist {
# this function is called recursively and generates a hierarchical directory listing in the bottom left frame
my ($dest) = shift;
my ($dir) = shift;
my ($level) = shift;
# add a trailing '/' if there is not one already
$dest .= '/' unless ($dest =~ /.*\$/);
$dir .= '/' unless ($dir =~ /.*\$/);
my ($filename, $spacer, @filelist, $attempt, $realdir, $test, $margurl, $bodyurl, $dirurl);
$spacer = '<BR>' . ('-' x $level);
$level++;
opendir (THISDIR, $path.$dir);
@filelist = readdir THISDIR;
closedir THISDIR;
FILE: foreach $attempt (sort @filelist) {
# skip if file starts with a period (.) (this fixes '.', '..', and any *hidden* files)
next FILE if ($attempt =~ /^\..*/);
$filename = $attempt;
# truncate the path information if there is any.
$filename =~ s!^.*/!!;
# rebuild the full filename.
$realdir = $path.$dir.$attempt;
# is the file a symbolic link?
if (-l $realdir) {
# if the file is a symbolic link, then we want to reference the directory the link
# points to (if it is a directory which we will determine later ...)
$realdir = readlink ($realdir);
# $realdir is now the symbolic link which is either relative or absolute.
# it is absolute if it begins with a '/'
leave $realdir untouched if it is absolute, otherwise, append it to the link location.
$realdir = $path.$dir.$realdir unless ($realdir =~ /^\//);
}
if (-d $realdir) {
# right, the object we are looking at is a directory. We are only interested in directories
# so this is a good thing.
$test = $path.$dir.$attempt;
$dirurl = CGI->escape ($dir.$attempt);
$margurl = $self.'?action=margin&dir='.$dirurl;
$bodyurl = $self.'?action=subform&dir='.$dirurl;
# if the directory we are looking at now is on the path to the bottom directory,
# then print an open folder image
if ($dest =~ /^$test/) {
print $spacer,
a ({-href => $margurl,
-target => 'margin',
-name => $dirurl},
img ({-src=>$folderopenpic,
-border=>0,
-width=>15,
-height=>15})),
a ({-href => $bodyurl,
-target => 'subform'},
$filename),
"\n";
# recursive call for next level in hierarchy
dirlist ($dest, $dir.$attempt, $level);
} else {
# otherwise print a closed folder image
print $spacer,
a ({-href => $margurl,
-target => 'margin',
-name => $dirurl},
img ({-src=>$folderpic,
-border=>0,
-width=>15,
-height=>15})),
a ({-href => $bodyurl,
-target => 'subform'},
$filename),
"\n";
}
} else {
# It is not a directory, must be a file
# print p ($spacer, img ({-src=>$filepic}), $filename);
# do nothing
print "";
}
}
}
sub marginframe {
my ($dest);
# the browser must have no concept of the actual file locations, and must all be relative to the $path directory.
# thus add $path to the beginning of the browser's perception of the file location.
$dest = $path.param ('dir');
print header ();
print start_html (-bgcolor=>'white', -background => '/wallpaper/gray2.jpg');
print h3 ('Directories');
# start the recursive list of directory hierarchies.
dirlist ($dest,'', 0);
print end_html ();
}
sub bodyframe {
# this sets up the frame to recieve thumbnail images of all images in the directory
# given in the relative param ('dir') variable.
print header ();
print start_html (-bgcolor=>'white', -background => '/wallpaper/gray2.jpg');
print h3 ('Thumbnails');
my ($dir, @filelist, $file, $url, $thumb, $thumbfile, $filesize);
$dir = param ('dir');
opendir PICFILES, $path.$dir or print "Could not open $!";
@filelist = readdir (PICFILES);
closedir PICFILES;
FILELOOP: foreach $file (sort @filelist) {
# only interested in files with .jpeg, .jpg, .gif, .bmp extensions
next FILELOOP unless ($file =~ /\.jpeg$|\.jpg$|\.bmp$|\.gif$/);
# get the filesize from stat - this is used as part of the images alternative description
(undef, undef, undef, undef, undef, undef, undef, $filesize, undef) = stat ($path.$dir.'/'.$file);
# convert to kilobytes not bytes
$filesize /= 1024;
# round the kilobytes off.
$filesize = sprintf ("%.0f", $filesize);
# this is the URL to get the thumbnail from.
$thumb=$self."?action=thumb&thumb=".CGI->escape($dir.'/'.$file);
# this is the URL to get the actual image from (full size).
$url=$self."?action=htmlimage&image=".CGI->escape($dir.'/'.$file)."&file=".CGI->escape ($file);
if (lc($file) =~ /\.jpg|\.bmp$|\.gif$/) {
# build an image type if it is an image we understand
$thumbfile = img ({-src =>$self."?action=thumb&thumb=".CGI->escape ($dir.'/'.$file),
-alt =>$file." ".$filesize. 'k',
-height=>$thumbsize,
-width =>$thumbsize,
-border=>0});
} else {
# just use the filename otherwise.
$thumbfile = $file;
}
print a ({-href=>$url,
-target=>$file},
$thumbfile
);
}
print end_html ()
}
sub htmlimage {
# this builds a blank page in which to show the full image.
my ($image, $file);
$image = CGI->escape (param ('image'));
$file = param ('file');
print header ();
print start_html ($file);
# create the reference to the image
print img ({-src => "$self?action=image&image=".$image,
-alt => $file});
print end_html ();
}
sub getimage {
# this outputs as stdout te actual full image
my (@contents, $file, $type);
$file = $path . param ('image');
if ($file =~ /\.gif$|\.bmp$/) {
$file =~ s/ /\\ /g;
$file =~ s/&/\\&/g;
$file =~ s/'/\\'/g;
$file =~ s/"/\\"/g;
$file = $cjpeg . $file . " |";
}
$type = 'image/jpeg';
print header ($type);
open PIC, $file;
binmode PIC;
foreach (<PIC>) {
print;
}
}
sub getthumb {
# this outputs the actual thumbnail image
# this is where serious optimisation should happen because
# this is called once per thumbnail.
my ($convert, $file, $command, @image);
print header ('image/jpeg');
$file = $path . param ('thumb');
# escape various nasties which may appear in the file name
# for me this is useful to include windows SMB mounts ...
$file =~ s/ /\\ /g;
$file =~ s/'/\\'/g;
$file =~ s/"/\\"/g;
$file =~ s/&/\\&/g;
# this is the thumbnail conversion command
$convert = "/usr/X11/bin/convert -colors 256 -compress JPEG -geometry ${thumbsize}x${thumbsize} $file -";
open PIC, $convert;
binmode PIC;
@image = <PIC>;
close PIC;
# output the thumbnail
print @image;
}
# initialise the variables ...
$| = 1;
$self = url();
$title = 'Pic Browser';
$filepic='/icons/image2.gif';
$folderpic='/icons/folder.gif';
$folderopenpic='/icons/folder.open.gif';
$action = param ('action');
$action = 'form' unless $action;
# this is the base directory from where the browser can "see" files.
# For me, this directory includes a number of symlinks to the various
# places I have photo's / scans including SMBmounts
$path = '/usr/local/httpd/picbrowser';
# the size in pixels to create the thumbnails
$thumbsize=100;
# this redirects program logic to the function related to the param('action')
frames () if $action eq 'form';
subformframe () if $action eq 'subform';
marginframe () if $action eq 'margin';
bodyframe () if $action eq 'body';
headingframe () if $action eq 'heading';
getthumb () if $action eq 'thumb';
htmlimage () if $action eq 'htmlimage';
getimage () if $action eq 'image';
exit 0;
------------------------------
Date: 20 Oct 1999 07:50:18 -0500
From: abigail@delanet.com (Abigail)
Subject: Re: SGML/HTML parsing tool
Message-Id: <slrn80rejk.fji.abigail@alexandra.delanet.com>
Christopher R. Maden (crism@exemplary.net) wrote on MMCCXLI September
MCMXCIII in <URL:news:crism-2010990243160001@pm3b-12.meer.net>:
;;
;; Have you tried HTML::Parser for parsing HTML?
Yes, I have. It's about as useful for parsing HTML as a table is
to do shopping with.
HTML::Parser doesn't parse, nor does it have any HTML knowledge.
Abigail
--
perl -wleprint -eqq-@{[ -eqw+ -eJust -eanother -ePerl -eHacker -e+]}-
-----------== Posted via Newsfeeds.Com, Uncensored Usenet News ==----------
http://www.newsfeeds.com The Largest Usenet Servers in the World!
------== Over 73,000 Newsgroups - Including Dedicated Binaries Servers ==-----
------------------------------
Date: 20 Oct 1999 11:55:59 GMT
From: oliver.cookYTTFIT@ukonline.co.uk
Subject: Substitution
Message-Id: <7ukakf$8t1$1@apple.news.easynet.net>
I'm having trouble with substitution. What I am trying to do, is write
a perl script that will prepare my .plan file for display on the web.
That means changing \n for <p> and changing *text* to <b>text</b>.
I wrote this script, but it bombs with the error "Can't modify array
deref in substitution at /usr/local/apache/cgi-bin/plan.pl line 6,
near "s/\n/\<p\>/;""
The script is:
#!/usr/bin/perl
print "content-type:text/html\n\n";
open (PLAN, "/home/ollie/.plan") || die "could not open plan file";
@plan = <PLAN>;
close(PLAN)||die "could not close plan file";
@plan =~ s/\n/\<p\>/;
print @plan;
Any help on this one would be very gratefully received.
Regards,
Ollie Cook
Please remove the YTTFIT before replying by email.
***** Posted via the UK Online online newsreader *****
Go to http://www.ukonline.co.uk to find out
about other online services we offer our subscribers.
------------------------------
Date: Wed, 20 Oct 1999 08:38:31 -0400
From: Jeff Pinyan <jeffp@crusoe.net>
Subject: Re: Substitution
Message-Id: <Pine.GSO.4.10.9910200808050.21020-100000@crusoe.crusoe.net>
=cut
=begin FOR HUMANS
This message can be sent through pod2text (or any other converter). It is
readable in this format, though. You can check
perldoc perlpod
for more information on this handy documentation markup.
=end FOR HUMANS
=head1 SYNOPSIS
I want to do some substitution on each element of an array.
=head1 DESCRIPTION
> I wrote this script, but it bombs with the error "Can't modify array
> deref in substitution at /usr/local/apache/cgi-bin/plan.pl line 6,
> near "s/\n/\<p\>/;""
This is due to the fact that pattern matching works on scalar values. So
the code C<@array =~ s/foo/bar/;> will evaluate @array in scalar context,
which returns the number of elements, which is a constant integer value.
You can't do C<100 =~ s/foo/bar/;> because you can't modify a constant
value like that.
=head1 EXAMPLES
=head2 Good Practice
> #!/usr/bin/perl
You should use the B<-w> option. It's good practice. And C<use strict;>
doesn't hurt either. Good programming practices make good programs.
> print "content-type:text/html\n\n";
This is a poorly formed HTTP header. While it won't kill you, it might
help to make it more readable, and copy the format used by generators of
HTTP headers:
print "Content-type: text/html\n\n";
=head2 To-Browser Error Reporting
> open (PLAN, "/home/ollie/.plan") || die "could not open plan file";
If you want the browser to give you a helpful error message, use the
CGI::Carp module and export fatalsToBrowser() from it. Also, you might
want to include the REASON for the inability to open the F<.plan> file:
use CGI::Carp qw( fatalsToBrowser );
open PLAN, "/home/ollie/.plan" or die "could not open .plan file: $!";
The same goes for the closing of the filehandle:
> close(PLAN)||die "could not close plan file";
could be written as:
close PLAN or die "could not close .plan file: $!";
=head2 File Slurping
> @plan = <PLAN>;
Ah, you'll want to be changing data in the F<.plan> file, so I will
present one method that will allow you to efficiently slurp the entire
file into a single scalar variable. It requires you understand the $/
variable, information on which can be found in L<perlvar>, and the local()
function, information on which can be found in L<perlfunc>, or by typing
C<perldoc -f local> at your nearest command line.
{
local $/;
$contents = <PLAN>;
}
Now the entire file is in the $contents variable.
=head2 Substitution
> @plan =~ s/\n/\<p\>/;
Well, we already know that won't work on arrays. Let's rewrite this using
the $contents variable.
$contents =~ s/\n/<p>/;
The backslashes before the < and > aren't needed. Now, this regex will
only change the FIRST \n to a <p> tag. You need to tell the regex to
operate globally:
$contents =~ s/\n/<p>/g;
We also want to change *....* to <b>....</b>, so we need another regex:
$contents =~ s/\*([^*]+)\*/<b>$1</b>/g;
# or
# @tag = qw( <b> </b> );
# $contents =~ s/\*/$tag[$i++ % 2]/g;
The * must be backslashed because it is a special regex character. More
information on the construction and meaning of these regexes can be found
in L<perlre>. The C<qw> operator can be found in L<perlop>.
=head2 Printing the Contents
> print @plan;
Now, it's just
print $contents;
However, it might be a good idea to include some HTML tags before and
after this content output.
<html>
<body>
content...
</body>
</html>
And if you're really hardcode, you could include the doctype. But I admit
I rarely follow that practice.
=head1 SEE ALSO
L<perlfunc>, for local(). L<perlvar>, for $/. L<perlre>, for information
on construction of regular expressions. L<perlop>, for information on the
C<qw> operator. L<perlpod>, for information on writing, reading, and
filtering POD (Plain Old Documentation).
=head1 AUTHOR
--
MIDN 4/C PINYAN, USNR, NROTCURPI
jeff pinyan japhy@pobox.com
perl stuff japhy+perl@pobox.com
CPAN ID: PINYAN http://www.perl.com/CPAN/authors/id/P/PI/PINYAN/
------------------------------
Date: Wed, 20 Oct 1999 08:48:47 -0400
From: Jeff Pinyan <jeffp@crusoe.net>
Subject: Re: Substitution
Message-Id: <Pine.GSO.4.10.9910200847350.21020-100000@crusoe.crusoe.net>
On Oct 20, Jeff Pinyan blah blah blah:
> =head1 EXAMPLES
>
> =head2 Good Practice
>
> > #!/usr/bin/perl
>
> You should use the B<-w> option. It's good practice. And C<use strict;>
> doesn't hurt either. Good programming practices make good programs.
While endorsing the strict pragma, I forgot to remind that you must
declare your variables in some way, such as:
use vars qw( $content );
# or
$::content = ...;
# or
my $content;
my $bad;
--
MIDN 4/C PINYAN, USNR, NROTCURPI
jeff pinyan japhy@pobox.com
perl stuff japhy+perl@pobox.com
CPAN ID: PINYAN http://www.perl.com/CPAN/authors/id/P/PI/PINYAN/
------------------------------
Date: Wed, 20 Oct 1999 13:58:00 +0200
From: Alex Rhomberg <rhomberg@ife.ee.ethz.ch>
Subject: Re: Unix command ´tree´ in Perl?
Message-Id: <380DAE48.8904C46F@ife.ee.ethz.ch>
> > perl -le'print STDERR "tree: Command not found"; exit 1'
> >
> > - Alex
> >
> > PS The Linux boxes do it a bit differently
>
> This should emulate correctly the Linux behaviour - with the added benefit
> it will emulate the behaviour of any command if renamed as that command
> a truly universal program :
Not exactly. On my Linux boxes, it is a bit different:
> which tree
/usr/bin/tree
rpm -q tree
tree-0.something-or.other
- Alex
------------------------------
Date: 20 Oct 1999 07:58:29 -0500
From: abigail@delanet.com (Abigail)
Subject: Re: Unix command =?iso-8859-1?Q?=B4tree=B4?= in Perl?
Message-Id: <slrn80rf31.fji.abigail@alexandra.delanet.com>
Alex Rhomberg (rhomberg@ife.ee.ethz.ch) wrote on MMCCXLI September
MCMXCIII in <URL:news:380DAE48.8904C46F@ife.ee.ethz.ch>:
$$ > > perl -le'print STDERR "tree: Command not found"; exit 1'
$$ > >
$$ > > - Alex
$$ > >
$$ > > PS The Linux boxes do it a bit differently
$$ >
$$ > This should emulate correctly the Linux behaviour - with the added benefit
$$ > it will emulate the behaviour of any command if renamed as that command
$$ > a truly universal program :
$$
$$ Not exactly. On my Linux boxes, it is a bit different:
$$
$$ > which tree
$$ /usr/bin/tree
Yeah, and it's even much easier to simulate:
$ /usr/bin/tree
Segmentation fault
$ perl -wle 'print "Segmentation fault"'
Segmentation fault
$
HTH. HAND.
Abigail
--
perl -e '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
/ / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / /
% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %;
BEGIN {% % = ($ _ = " " => print "Just Another Perl Hacker\n")}'
-----------== Posted via Newsfeeds.Com, Uncensored Usenet News ==----------
http://www.newsfeeds.com The Largest Usenet Servers in the World!
------== Over 73,000 Newsgroups - Including Dedicated Binaries Servers ==-----
------------------------------
Date: Wed, 20 Oct 1999 14:45:14 +0200
From: Matthias Nutt <nutt@forwiss.uni-erlangen.de_antispam_>
Subject: Re: why doesn't my script work?
Message-Id: <380DB95A.14D92258@forwiss.uni-erlangen.de_antispam_>
why dont you use the unix tool ruptime?
Matthias
------------------------------
Date: 16 Sep 99 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 16 Sep 99)
Message-Id: <null>
Administrivia:
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
| NOTE: The mail to news gateway, and thus the ability to submit articles
| through this service to the newsgroup, has been removed. I do not have
| time to individually vet each article to make sure that someone isn't
| abusing the service, and I no longer have any desire to waste my time
| dealing with the campus admins when some fool complains to them about an
| article that has come through the gateway instead of complaining
| to the source.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V9 Issue 1128
**************************************
