|
|
- #!/usr/bin/perl
-
- =pod
-
- =head1 NAME
-
- Display - module to display fragments of text on the web and elsewhere
-
- =head1 SYNOPSIS
-
- #!/usr/bin/perl
-
- use Display qw(%WalaConf %DISPLAY_CONF &handle);
-
- do 'conf.pl' if -e 'conf.pl'; # grab config
-
- $WalaConf{'ShowSearchlinks'} = 0;
-
- print handle(@ARGV);
-
- =head1 DESCRIPTION
-
- Display started life as a simple script to concatenate fragments of handwritten
- HTML by date. It has since haphazardly accumulated several of the usual weblog
- features (comments, lightweight markup, feed generation, embedded Perl, poetry
- tools, ill-advised dependencies), but the basic idea hasn't changed much.
-
- The module will work with FastCGI, via CGI::Fast, if called from the
- appropriate wrapper script.
-
- Entries are stored in a simple directory tree under
- C<$DISPLAY_CONF{ROOT_DIR}>.
-
- Like:
-
- archives/2001/1/1
- archives/2001/1/1/sub_entry
-
- An entry may be either a plain text file, or a directory containing several
- such files + whatever else you'd like to store. If it's a directory, the file
- called "index" will be treated as the text of the entry, and all other lower
- case filenames without extensions will be treated as sub-entries or documents
- within that entry, and displayed accordingly.
-
- Directories may be nested to an arbitrary depth, though I don't promise that
- this won't break on you.
-
- A PNG or JPEG file with a name like
-
- 2001/1/1.icon.png
- 2001/1/1/index.icon.png
- 2001/1/1/whatever.icon.png
-
- will be treated as an icon for the appropriate entry file.
-
- =head2 MARKUP
-
- Entries may consist of hand-written HTML (to be passed along without further
- interpretation), a supported form of lightweight markup, or some combination
- thereof. Actually, an entry may consist of any darn thing you please, as long
- as Perl will agree that it is text, but presumably you're going to be feeding
- this to a browser.
-
- Special markup is indicated by a variety of XML-style container tags.
-
- B<Embedded Perl> - evaluated and replaced by whatever value you return
- (evaluated in a scalar context):
-
- <perl>my $dog = "Ralph."; return $dog;</perl>
-
- This code is evaluated before any other processing is done, so you can return
- any other markup understood by the script and have it handled appropriately.
-
- B<Interpolated variables> - actually keys to %TEMPLATE, for the moment:
-
- <perl>$TEMPLATE{dog} = "Ralph"; return '';</perl>
- <p>My dog is named ${dog}.</p>
-
- Embedded code and variables are mostly intended for use in F<header> and
- F<footer> files, where it's handy to drop in titles or conditionalize aspects
- of a layout. You want to be careful with this sort of thing - it's useful in
- small doses, but it's also a maintainability nightmare waiting to happen.
- (WordPress, I am looking at you.)
-
- B<Several forms of lightweight markup>:
-
- <wala>Wala::Markup, via Wala.pm - very basic wiki syntax</wala>
-
- <textile>Dean Allen's Textile, via Brad Choate's
- Text::Textile.</textile>
-
- <freeverse>An easy way to
- get properly broken lines
- -- en and em dashes ---
- for poetry and such.</freeverse>
-
- B<And a couple of shortcuts>:
-
- <image>filename.ext
- alt text, if any</image>
-
- <list>
- one list item
-
- another list item
- </list>
-
- As it stands, freeverse, image, and list are not particularly robust.
-
- =cut
-
- package Display;
-
- use strict;
- use warnings;
- no warnings 'uninitialized';
-
- BEGIN {
- use base qw(Exporter);
- our @EXPORT_OK = qw(%WalaConf %DISPLAY_CONF &handle);
-
- use XML::Atom::SimpleFeed;
- use Wala qw(%WalaConf %DISPLAY_CONF);
-
- use Display::HTML qw(:highlevel);
- use Display::Markup qw(line_parse);
- use Display::Image qw(image_size);
- }
-
- our @EXPORT_OK;
-
- ######################
- # DEFAULT OPTIONS #
- ######################
-
- %DISPLAY_CONF = (
- ROOT_DIR => 'archives', # root dir for archived files
- URL_ROOT => 'http://p1k3.com/', # root URL for building links
- IMAGE_URL_ROOT => 'http://p1k3.com/', # same for images
- HEADER => 'header',
- FOOTER => 'footer',
- );
-
- $WalaConf{'ShowSearchlinks'} = 0;
-
- =head1 METHODS
-
- For no bigger than this thing is, it gets a little convoluted.
-
- =over
-
- =item new
-
-
-
- =cut
-
- sub new {
- my $class = shift;
- my (@params) = @_;
-
- my $self = {};
-
- bless $self;
- return $self;
- }
-
- =item handle
-
- Handle a given request, either in the form of a CGI query object
- or a date/entry string.
-
- =cut
-
- sub handle {
- my (@options) = @_;
- my $output;
-
- # Get parameters from any CGI objects we've been given:
- @options = map { expand_query($_) } @options;
-
- # By default, we display the most recent month.
- $options[0] = 'new' unless $options[0];
-
- # Title for head/foot template:
- $DISPLAY_CONF{title} = join ' ', @options;
-
- # Maps 'all' and 'new' to appropriate entries:
- @options = map { expand_option($_) } @options;
-
- for my $o (@options) {
- return feed_print() if $o eq 'feed';
- $output .= output($o);
- }
-
- # Wrap entries in header/footer:
- $output = fragment_slurp($DISPLAY_CONF{HEADER})
- . $output
- . fragment_slurp($DISPLAY_CONF{FOOTER});
-
- return $output;
- }
-
- =item output
-
- Returns appropriate output for a given option.
-
- =cut
-
- sub output {
- my ($option) = @_;
-
- if ( $option =~ m'^[0-9/]{5,11}[a-z_/]+$' ) {
- # nnnn/[nn/nn/]doc_name
- # It's a document within a date.
- return entry_markup(entry_print($option) . datestamp($option));
- }
- elsif ( $option =~ m'^[0-9]{4}/[0-9]{1,2}/[0-9]{1,2}$' ) {
- # nnnn/nn/nn - A specific date. Print it in full.
- return entry_markup(entry_print($option, 'all') . datestamp($option));
- }
- elsif ( $option =~ m'^[0-9]{4}/[0-9]{1,2}$' ) {
- # nnnn/nn - It's a month. Print it.
- return month_print($option);
- }
- elsif ( $option =~ m'^[0-9]{4}$' ) {
- # nnnn - It's a year. Display a list of entries.
- return year_print($option);
- }
- elsif ($option eq 'portfolio') {
- return entry_print($option, 'all');
- }
- elsif ($option =~ m'^[a-z_]') {
- # Assume it's a document in the root directory.
- return entry_markup(entry_print($option, 'all'));
- }
-
- }
-
-
- =item expand_query
-
- Expands a CGI query (for example, one passed in from CGI::Fast) to an
- appropriate list of parameters.
-
- =cut
-
- sub expand_query {
- my ($option) = shift;
- if ( (ref($option) eq 'CGI::Fast') or (ref($option) eq 'CGI')) {
- return $option->param('keywords');
- } else {
- return $option;
- }
- }
-
-
- =item expand_option
-
- Expands/converts 'all' and 'new' to appropriate values.
-
- =cut
-
- sub expand_option {
- my ($option) = shift;
-
- # take care of trailing slashes
- chop ($option) if (substr($option, -1, 1) eq '/');
-
- if ($option eq 'all') {
- return dir_list($DISPLAY_CONF{ROOT_DIR}, 'high_to_low',
- qr/^[0-9]{1,4}$/);
- } elsif ($option eq 'new') {
- return recent_month();
- } else {
- return $option;
- }
-
- }
-
-
- =item recent_month
-
- Tries to find the most recent month in the archive.
-
- If a year file is text, returns that instead.
-
- =cut
-
- sub recent_month {
-
- my ($dir) = $DISPLAY_CONF{ROOT_DIR};
-
- # Below replaces:
- # my ($sec, $min, $hour, $mday, $mon,
- # $year, $wday, $yday, $isdst) = localtime(time);
- my ($mon, $year) = (localtime time)[4,5];
-
- $mon++;
- $year += 1900;
-
- if (-e "$dir/$year/$mon") {
- return "$year/$mon";
- }
- else {
-
- my @year_files = dir_list($dir, 'high_to_low', qr/^[0-9]{1,4}$/);
-
- if (-T "$dir/$year_files[0]") {
- return $year_files[0];
- }
-
- my @month_files = dir_list("$dir/$year_files[0]", 'high_to_low',
- qr/^[0-9]{1,2}$/);
-
- return "$year_files[0]/$month_files[0]";
- }
-
- }
-
-
- =item month_before
-
- Return the month before the given month in the archive.
-
- Very naive; there has got to be a smarter way.
-
- =cut
-
- { my %cache; # cheap memoization
-
- sub month_before {
- my ($this_month) = @_;
-
- if (exists $cache{$this_month}) {
- return $cache{$this_month};
- }
-
- my ($year, $month) = ( $this_month =~ m/^ # start of string
- ([0-9]{4}) # 4 digit year
- \/ #
- ([0-9]{1,2}) # 2 digit month
- /x );
-
- if ($month == 1) {
- $month = 12;
- $year = $year - 1;
- } else {
- $month--;
- }
-
- until (-e "$DISPLAY_CONF{ROOT_DIR}/$year/$month") {
-
- if (! -d "$DISPLAY_CONF{ROOT_DIR}/$year") {
- # give up easily
- return 0;
- }
-
- # handle January:
- if ($month == 1) {
- $month = 12;
- $year--;
- next;
- }
- $month--;
- }
-
- return $cache{$this_month} = "$year/$month";
-
- }
- }
-
-
- =item dir_list
-
- Return a $sort_order sorted list of files matching regex $pattern in a
- directory.
-
- Calls $sort_order, which can be one of:
-
- alpha - alphabetical
- reverse_alpha - alphabetical, reversed
- high_to_low - numeric, high to low
- low_to_high - numeric, low to high
-
- =cut
-
- sub dir_list {
- my ($dir, $sort_order, $file_pattern) = @_;
-
- $file_pattern = qr/^[0-9]{1,2}$/ unless ($file_pattern);
- $sort_order = 'high_to_low' unless ($sort_order);
-
- opendir LIST_DIR, $dir
- or die "Couldn't open $dir: $!";
-
- my @files = sort $sort_order
- grep { m/$file_pattern/ }
- readdir LIST_DIR;
-
- closedir LIST_DIR;
-
- return @files;
- }
-
- # various named sorts for dir_list
- sub alpha { $a cmp $b; } # alphabetical
- sub high_to_low { $b <=> $a; } # numeric, high to low
- sub low_to_high { $a <=> $b; } # numberic, low to high
- sub reverse_alpha { $b cmp $a; } # alphabetical, reversed
-
-
- =item year_print
-
- List out the updates for a year.
-
- =cut
-
- sub year_print {
- my ($year) = @_;
- my ($year_file) = "$DISPLAY_CONF{ROOT_DIR}/$year";
- my ($year_url) = "$DISPLAY_CONF{URL_ROOT}$year";
- my $result;
-
- if (-d $year_file) {
-
- # Handle year directories with index files.
- $result .= entry_print($year) if -T "$year_file/index";
-
- # this is stupid:
- my $header_text = icon_markup($year, $year);
- $header_text = '' unless $header_text;
-
- $result .= heading("$header_text $year", 3);
-
- my @months = dir_list($year_file, 'high_to_low', qr/^[0-9]{1,2}$/);
-
- my $year_text;
- my $count = 0; # explicitly defined for later printing.
-
- foreach my $month (@months) {
- my @entries = dir_list("$year_file/$month", 'low_to_high',
- qr/^[0-9]{1,2}$/);
-
- # Add the count of files to $update_count:
- $count += @entries;
-
- my $month_text;
- foreach my $entry (@entries) {
- $month_text .= a("href: $year_url/$month/$entry", $entry) . "\n";
- }
- $month_text = small('(' . $month_text . ')');
-
- my $link = a("href: $year_url/$month", month_name($month));
- $year_text .= table_row(
- table_cell('class: datelink', $link),
- table_cell('class: datelink', $month_text)
- ) . "\n\n";
- }
-
- $result .= "\n\n" . table($year_text) . "\n";
-
- if ($count > 1) {
- my ($average) = int($count / @months);
- $count = "$count entries, roughly $average an active month.";
- }
- elsif ($count == 0) { $count = $count . ' entries'; }
- elsif ($count == 1) { $count = $count . ' entry'; }
-
- $result .= p($count);
-
- } elsif (-T $year_file) {
- $result .= entry_print($year);
- } else {
- $result .= p('No such year.');
- }
-
- return entry_markup($result);
- }
-
- =item month_print
-
- Prints the entries in a given month (nnnn/nn).
-
- =cut
-
- sub month_print {
- my ($month) = @_;
- my $month_file = "$DISPLAY_CONF{ROOT_DIR}/$month";
- my $result;
-
- # If a directory exists for $month, use dir_list to grab
- # the entry files it contains into @entry_files, sorted
- # numerically. Then send each entry to entry_print.
- if (-d $month_file) {
- if (-T "$month_file/index") {
- $result .= entry_print($month);
- }
-
- my @entry_files = dir_list ($month_file, 'high_to_low',
- qr/^[0-9]{1,2}$/);
-
- foreach my $entry_file (@entry_files) {
- $result .= entry_markup( entry_print("$month/$entry_file")
- . datestamp("$month/$entry_file") );
- }
-
- } elsif (-T $month_file) {
- $result .= entry_print($month);
- }
-
- $result .= p( 'class: centerpiece',
- a("href: $DISPLAY_CONF{URL_ROOT}" . month_before($month), 'previous') ) . "\n\n";
-
- return $result;
- }
-
-
- =item entry_print
-
- Prints the contents of a given entry. Calls datestamp,
- dir_list, and icon_markup. Recursively calls itself.
-
- =cut
-
- sub entry_print {
- my ($entry, $level) = @_;
- $level = 'index' unless $level;
-
- # location of entry on local filesystem, and its URL:
- my $entry_loc = "$DISPLAY_CONF{ROOT_DIR}/$entry";
- my $entry_url = $DISPLAY_CONF{URL_ROOT} . $entry;
-
- my $result;
-
- # display an icon, if we have one:
- if ( my $ico_markup = icon_markup($entry) ) {
- $result .= heading($ico_markup, 2) . "\n\n";
- }
-
- if (-T $entry_loc) {
- # is text, slurp it and return
- return $result . fragment_slurp($entry_loc);
- } elsif (-d $entry_loc) {
-
- # print index as head
- $result .= fragment_slurp("$entry_loc/index");
-
- # followed by any sub-entries:
-
- my @sub_entries = get_sub_entries($entry_loc);
-
- if ( $level eq 'index' and @sub_entries >= 1 ) {
- # spit out icons or text links for extra files
- $result .= list_contents($entry, @sub_entries);
- } elsif ( $level eq 'all' and @sub_entries >= 1 ) {
-
- # or if we're supposed to print everything in the directory
- # and if there's more there than just the index file,
-
- foreach my $se (@sub_entries) {
- next if ($se =~ m/[.](tgz|zip|tar[.]gz|gz|txt)$/);
-
- # print each of the other files, separated by little headers
- #my $url = "$DISPLAY_CONF{URL_ROOT}$entry/$se";
- #$result .= "\n\n" . p('{' . a("href: $url", $se) . '}') . "\n\n";
-
- $result .= p('class: centerpiece', '+');
- $result .= entry_print("$entry/$se");
- }
-
- }
-
- }
-
- return $result;
- }
-
- sub get_sub_entries {
- my $entry_loc = shift;
- my $match = qr/^[a-z_]+(\.(tgz|zip|tar[.]gz|gz|txt))?$/;
-
- my %ignore = ('index' => 1);
- return grep { ! $ignore{$_} } dir_list ($entry_loc, 'alpha', $match);
- }
-
- sub list_contents {
- my ($entry) = shift;
- my (@entries) = @_;
-
- my $contents;
- foreach my $se (@entries) {
- my $linktext = icon_markup("$entry/$se", $se);
- $linktext = $se unless $linktext;
-
- $contents .= ' ' . a("href: $DISPLAY_CONF{URL_ROOT}$entry/$se",
- $linktext,
- "title: $se");
- }
-
- return p( em('more') . ": $contents" ) . "\n";
-
- }
-
- =item icon_markup
-
- Check if an icon exists for a given entry if so, return markup to include it.
- Icons are PNG or JPEG image files following a specific naming convention:
-
- index.icon.[png|jp(e)g] for directories
- [filename].icon.[png|jp(e)g] for flat text files
-
- Calls image_size, uses filename to determine type.
-
- =cut
-
- sub icon_markup {
- my ($entry, $alt) = @_;
-
- my ($entry_loc) = "$DISPLAY_CONF{ROOT_DIR}/$entry";
- my ($entry_url) = "$DISPLAY_CONF{IMAGE_URL_ROOT}${entry}";
-
- my ($icon_loc, $icon_url);
-
- if (-T $entry_loc) {
- $icon_loc = "$entry_loc.icon";
- $icon_url = "$entry_url.icon";
- }
- elsif (-d $entry_loc) {
- $icon_loc = "$entry_loc/index.icon";
- $icon_url = "$entry_url/index.icon";
- }
-
- # put a list of icon image types to check for here
- # (first one found will be used)
- my (@suffixes) = qw(png gif jpg jpeg);
- my $suffix = "";
- for (@suffixes) {
- if (-e "$icon_loc.$_") {
- $suffix = $_;
- last;
- }
- }
-
- # fail unless there's a file with one of the above suffixes
- return 0 unless $suffix;
-
- # call image_size to slurp width & height from the image file
- my ($width, $height) = image_size("$icon_loc.$suffix");
-
- return qq{<img src="$icon_url.$suffix"\n width="$width" }
- . qq{height="$height"\n alt="$alt" />};
- }
-
- =item datestamp
-
- Returns a nice html datestamp for a given entry, including a wikilink for
- discussion and suchlike.
-
- =cut
-
- sub datestamp {
- my ($entry) = @_;
-
- my ($stamp);
- if ( $entry =~ m{(^[0-9]{4}/[0-9]{1,2}/[0-9]{1,2})} ) {
-
- my ($entry_year, $entry_month, $entry_day) = split (/\//, $1);
-
- # this stuff conditionalizes the wikilink
- # so that if nothing exists, you wind up with an edit form
- my ($wiki_date_name) = month_name($entry_month) .
- "_${entry_day}_${entry_year}";
-
- my $wikistamp = ':: ';
-
- if (-e "$WalaConf{PagesDir}/${wiki_date_name}") {
- $wikistamp .= a("href: $WalaConf{ScriptName}?$wiki_date_name",
- 'read the margins',
- 'title: a page you can edit');
- } else {
- $wikistamp .= a("href: $WalaConf{ScriptName}?$wiki_date_name",
- 'write in the margins',
- 'title: a page you can edit');
- }
-
- # return a fancy datestamp.
-
- my $month_name = month_name($entry_month);
- my $year_url = "href: $DISPLAY_CONF{URL_ROOT}$entry_year";
- $stamp = "\n "
- . a($year_url, $entry_year, "title: $entry_year") . "\n "
- . a("$year_url/$entry_month", $month_name, "title: $entry_year/$entry_month") . "\n "
- . a("$year_url/$entry_month/$entry_day", $entry_day, "title: $entry_year/$entry_month/$entry_day") . "\n "
- . $wikistamp . "\n";
- } else {
- $stamp = "(failed to construct datestamp for $entry)";
- }
-
- return p('class: datelink', $stamp);
- }
-
-
- =item fragment_slurp
-
- Read a text fragment, call line_parse to take care of funky markup and
- interpreting embedded code, and then return it as a string. Takes one
- parameter, the name of the file, and returns '' if it's not an extant text
- file.
-
- This might be the place to implement an in-memory cache for FastCGI or mod_perl
- environments. The trick is that the line_parse() results for certain files
- shouldn't be cached because they contain embedded code.
-
- =cut
-
- sub fragment_slurp {
- my ($file) = @_;
-
- # if $file is text
- if (-T $file) {
- my $everything;
-
- open my $fh, '<', $file
- or die "Couldn't open $file: $!\n";
-
- {
- # line sep
- local $/ = undef;
- $everything = <$fh>;
- }
-
- close $fh or die "Couldn't close: $!";
-
- # eval embedded Perl and ${variables}:
- eval_perl($everything);
-
- # Take care of any special markup.
- # We pass along $file so it has some context to work with
-
- return line_parse ($everything, $file);
-
- } else {
- return q{};
- }
- }
-
-
- =item eval_perl
-
- Evaluate embedded Perl in a string, replacing blocks enclosed with <perl> tags
- with whatever they return (well, evaluated in a scalar context). Modifies
- a string in-place, so be careful.
-
- Also handles simple ${variables}, replacing them (for now) from %DISPLAY_CONF
- values.
-
- =cut
-
- sub eval_perl {
-
- while ($_[0] =~ m/<perl>(.*?)<\/perl>/s) {
- my $block = $1;
-
- my $output = eval $block;
-
- if ($@) {
- # got an error
- $_[0] =~ s/<perl>\Q$block\E<\/perl>/$@/s;
- } else {
- # include anything returned from $block
- $_[0] =~ s/<perl>\Q$block\E<\/perl>/$output/s;
- }
- }
-
- # interpolate variables
- $_[0] =~ s/\${([a-zA-Z_]+)}/$DISPLAY_CONF{$1}/ge;
-
- return;
- }
-
-
- =item month_name
-
- Turn numeric dates into English.
-
- =cut
-
- sub month_name {
- my ($number) = @_;
-
- # "Null" is here so that $month_name[1] corresponds to January, etc.
- my @months = qw(Null January February March April May June
- July August September October November December);
-
- return $months[$number];
- }
-
-
- =item feed_print
-
- Return an Atom feed of entries for a month. Defaults to the most
- recent month in the archive.
-
- Called from handle(), requires XML::Atom::SimpleFeed.
-
- =cut
-
- sub feed_print {
- my $month = shift;
- $month = recent_month() unless defined $month;
-
- # create a feed object
- my $feed = XML::Atom::SimpleFeed->new(
- title => $DISPLAY_CONF{title},
- link => $DISPLAY_CONF{URL_ROOT},
- link => { rel => 'self', href => $DISPLAY_CONF{feed_url}, },
- icon => $DISPLAY_CONF{favicon_url},
- author => $DISPLAY_CONF{author},
- id => $DISPLAY_CONF{URL_ROOT},
- generator => "Display.pm / XML::Atom::SimpleFeed",
- );
-
- # If a directory exists for $month, use dir_list to grab
- # the entry files it contains into @entry_files, sorted
- # numerically. Then send each entry to entry_print.
-
- my @entry_files;
-
- if (-d "$DISPLAY_CONF{ROOT_DIR}/$month") {
- (@entry_files) = dir_list ("$DISPLAY_CONF{ROOT_DIR}/$month",
- 'high_to_low',
- qr/^[0-9]{1,2}$/);
- } else {
- return 0;
- }
-
- foreach my $entry_file (@entry_files) {
- # Going to feed this to SimpleFeed.
- my $content = entry_print("$month/$entry_file");
-
- $feed->add_entry(
- title => "$month/$entry_file",
- link => $DISPLAY_CONF{URL_ROOT} . "$month/$entry_file",
- id => $DISPLAY_CONF{URL_ROOT} . "$month/$entry_file",
- content => $content,
- );
-
- }
-
- return "Content-type: application/atom+xml\n\n"
- . $feed->as_string;
-
- }
-
-
-
- =back
-
- =head1 SEE ALSO
-
- walawiki.org, Blosxom, rassmalog, Text::Textile, XML::Atom::SimpleFeed,
- Image::Size, CGI::Fast.
-
- =head1 AUTHOR
-
- Copyright 2001-2007 Brennen Bearnes
-
- Image sizing code (in image_size) derived from wwwis, by Alex Knowles and
- Andrew Tong.
-
- display.pl is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- =cut
-
- 1;
|