You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1183 lines
29 KiB
1183 lines
29 KiB
package Display;
|
|
|
|
our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x;
|
|
# $Author$
|
|
# $Date$
|
|
# $Id$
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
Display - module to display fragments of text on the web and elsewhere
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
#!/usr/bin/perl
|
|
|
|
use Display;
|
|
my $d = Display->new(
|
|
root_dir => 'archives',
|
|
url_root => '/display.pl?',
|
|
# etc.
|
|
);
|
|
print $d->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, image galleries, and ill-advised dependencies), but the basic idea
|
|
hasn't changed much.
|
|
|
|
The module will work with FastCGI, if called from the appropriate wrapper
|
|
script. If you use CGI::Fast, you can pass query objects directly to
|
|
C<handle()>.
|
|
|
|
By default, entries are stored in a simple directory tree under C<root_dir>.
|
|
|
|
Like:
|
|
|
|
archives/2001/1/1
|
|
archives/2001/1/1/sub_entry
|
|
|
|
It is possible (although not yet as flexible as it ought to be) to redefine
|
|
the directory layout. More about this after a bit.
|
|
|
|
An entry may be either a plain text file, or a directory containing several
|
|
files. If it's a directory, a file named "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. Links to certain other filetypes will be displayed as well.
|
|
|
|
Directories may be nested to an arbitrary depth, although it's probably not a
|
|
good idea to go very deep with the current display logic.
|
|
|
|
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
|
|
2001/1/1/whatever/index.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 HTML-like 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 the hash underlying the Display
|
|
object, for the moment:
|
|
|
|
<perl>$self->title("About Ralph, My Dog"); return '';</perl>
|
|
|
|
<p>The title is <em>${title}</em>.</p>
|
|
|
|
This will change.
|
|
|
|
Embedded code and variables are 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
|
|
plus -- 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.
|
|
|
|
=head1 NAME
|
|
|
|
Display - module to display fragments of text on the web and elsewhere
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
#!/usr/bin/perl
|
|
|
|
use Display;
|
|
my $d = Display->new(
|
|
root_dir => 'archives',
|
|
url_root => '/display.pl?',
|
|
# etc.
|
|
);
|
|
print $d->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, image galleries, and ill-advised dependencies), but the basic idea
|
|
hasn't changed much.
|
|
|
|
The module will work with FastCGI, if called from the appropriate wrapper
|
|
script. If you use CGI::Fast, you can pass query objects directly to
|
|
C<handle()>.
|
|
|
|
By default, entries are stored in a simple directory tree under C<root_dir>.
|
|
|
|
Like:
|
|
|
|
archives/2001/1/1
|
|
archives/2001/1/1/sub_entry
|
|
|
|
It is possible (although not yet as flexible as it ought to be) to redefine
|
|
the directory layout. More about this after a bit.
|
|
|
|
An entry may be either a plain text file, or a directory containing several
|
|
files. If it's a directory, a file named "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. Links to certain other filetypes will be displayed as well.
|
|
|
|
Directories may be nested to an arbitrary depth, although it's probably not a
|
|
good idea to go very deep with the current display logic.
|
|
|
|
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
|
|
2001/1/1/whatever/index.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 HTML-like 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 the hash underlying the Display
|
|
object, for the moment:
|
|
|
|
<perl>$self->title("About Ralph, My Dog"); return '';</perl>
|
|
|
|
<p>The title is <em>${title}</em>.</p>
|
|
|
|
This will change.
|
|
|
|
Embedded code and variables are 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
|
|
plus -- 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
|
|
|
|
use strict;
|
|
use warnings;
|
|
no warnings 'uninitialized';
|
|
|
|
use base 'MethodSpit';
|
|
|
|
use XML::Atom::SimpleFeed;
|
|
use Wala;
|
|
|
|
use Display::HTML qw(:highlevel);
|
|
use Display::Markup qw(line_parse image_markup);
|
|
use Display::Image qw(image_size);
|
|
|
|
=head1 CONFIGURATION
|
|
|
|
=over
|
|
|
|
=item options
|
|
|
|
See F<conf.pl> for a sample configuration.
|
|
|
|
=cut
|
|
|
|
my %default = (
|
|
root_dir => 'archives', # root dir for archived files
|
|
url_root => "$0?", # root URL for building links
|
|
image_url_root => '', # same for images
|
|
header => 'header',
|
|
footer => 'footer',
|
|
title => '',
|
|
stylesheet_url => undef,
|
|
favicon_url => undef,
|
|
feed_alias => 'feed',
|
|
author => undef,
|
|
description => undef,
|
|
license => undef,
|
|
http_header => 1,
|
|
default_entry => 'new',
|
|
|
|
# What gets considered an entry file:
|
|
entryfile_expr => qr/^[a-z_]+(\.(tgz|zip|tar[.]gz|gz|txt))?$/,
|
|
|
|
# We'll show links for these, but not display them inline:
|
|
binfile_expr => qr/[.](tgz|zip|tar[.]gz|gz|txt|pdf)$/,
|
|
|
|
wala => Wala->new(),
|
|
);
|
|
|
|
=item entry_map(\%map)
|
|
|
|
Takes a hashref which will dispatch entries matching various regexen to
|
|
the appropriate output methods. The default looks something like this:
|
|
|
|
nnnn/[nn/nn/]doc_name - a document within a day.
|
|
nnnn/nn/nn - a specific day.
|
|
nnnn/nn - a month.
|
|
nnnn - a year.
|
|
doc_name - a document in the root directory.
|
|
|
|
You can re-map things to an arbitrary archive layout.
|
|
|
|
Since the entry map is a hash, and handle() simply loops over its keys, there
|
|
is no guaranteed precedence of patterns. Be extremely careful that no entry
|
|
will match more than one pattern, or you will wind up with unexpected behavior.
|
|
A good way to ensure that this does not happen is to use patterns like:
|
|
|
|
qr(
|
|
^ # start of string
|
|
[0-9/]{4}/ # year
|
|
[0-9]{1,2}/ # month
|
|
[0-9]{1,2] # day
|
|
$ # end of string
|
|
)x
|
|
|
|
...always marking the start and end of the string explicitly.
|
|
|
|
=cut
|
|
|
|
$default{entry_map} = {
|
|
qr'^[0-9/]{5,11}[a-z_/]+$' => sub { entry_stamped (@_ ) },
|
|
|
|
qr'^[0-9]{4}/[0-9]{1,2}/
|
|
[0-9]{1,2}$'x => sub { entry_stamped (@_, 'all') },
|
|
|
|
qr'^[0-9]{4}/[0-9]{1,2}$' => sub { month (@_ ) },
|
|
qr'^[0-9]{4}$' => sub { year (@_ ) },
|
|
qr'^[a-z_]' => sub { entry_wrapped (@_, 'all') },
|
|
};
|
|
|
|
# Set up some accessor methods:
|
|
__PACKAGE__->methodspit( keys %default );
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
For no bigger than this thing is, it gets a little convoluted.
|
|
|
|
=over
|
|
|
|
=item new(%params)
|
|
|
|
Get a new Display object with the specified parameters set.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my %params = @_;
|
|
|
|
my $self = \%default;
|
|
bless $self, $class;
|
|
|
|
$self->configure(%params);
|
|
|
|
return $self;
|
|
}
|
|
|
|
=item configure(param => 'value')
|
|
|
|
Set specified parameters.
|
|
|
|
=cut
|
|
|
|
sub configure {
|
|
my $self = shift;
|
|
my %params = @_;
|
|
|
|
for my $p (keys %params) {
|
|
$self->{$p} = $params{$p};
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
=item walaconf(%options)
|
|
|
|
Set parameters for Wala.pm.
|
|
|
|
=cut
|
|
|
|
sub walaconf {
|
|
my $self = shift;
|
|
$self->wala->conf(@_);
|
|
return;
|
|
}
|
|
|
|
=item display($entry1, $entry2, ...)
|
|
|
|
Return a string containing the given entries, which can be in the form of CGI
|
|
query objects or date/entry strings. If no parameters are given, default to
|
|
default_entry().
|
|
|
|
display() expands aliases ("new" and "all") and CGI query objects as necessary,
|
|
collects input from handle($entry), and wraps the whole thing in header and
|
|
footer files.
|
|
|
|
=cut
|
|
|
|
sub display {
|
|
my $self = shift;
|
|
my (@options) = @_;
|
|
|
|
# Get parameters from any CGI queries, make sure we have at least the
|
|
# default, and expand on any aliases:
|
|
@options = map { expand_query($_) } @options;
|
|
$options[0] ||= $self->default_entry;
|
|
$self->title(join ' ', @options); # title for head/foot
|
|
@options = map { $self->expand_option($_) } @options;
|
|
|
|
my $output;
|
|
for my $option (@options) {
|
|
return $self->feed_print() if $option eq $self->feed_alias;
|
|
$output .= $self->handle($option);
|
|
}
|
|
|
|
# Wrap entries in header/footer:
|
|
my $header;
|
|
$header .= "Content-Type: text/html\n\n" if $self->http_header;
|
|
$header .= $self->fragment_slurp($self->header);
|
|
|
|
return $header
|
|
. $output
|
|
. $self->fragment_slurp($self->footer);
|
|
|
|
}
|
|
|
|
=item handle($entry)
|
|
|
|
Return the text of an individual entry.
|
|
|
|
=begin digression
|
|
|
|
=item A digression about each()
|
|
|
|
I just spent a lot of time chasing down a bug caused by the while loop
|
|
below. Specifically, since $self->entry_map returns a reference to the
|
|
same hash each time, every other request was finding each() mid-way
|
|
through iterating over this hash.
|
|
|
|
I solved this by copying this hash into a local one called %map every
|
|
time handle() is called. Another approach would be to call keys() or
|
|
values on the anonymous hash referenced by $self->entry_map, which
|
|
apparently resets each().
|
|
|
|
=end digression
|
|
|
|
=cut
|
|
|
|
sub handle {
|
|
my $self = shift;
|
|
my ($option) = @_;
|
|
|
|
# Hashref:
|
|
my $map = $self->entry_map;
|
|
|
|
# Take the first matching pattern:
|
|
my ($pattern) = grep { $option =~ $_ } keys %{ $map };
|
|
|
|
return unless defined $pattern;
|
|
return $map->{$pattern}->($self, $option);
|
|
}
|
|
|
|
|
|
=item expand_query
|
|
|
|
Expands a CGI query object (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 ($self, $option) = @_;
|
|
|
|
# Take care of trailing slashes:
|
|
#chop $option if substr($option, -1, 1) eq q{/};
|
|
chop $option if $option =~ m{/$};
|
|
|
|
if ($option eq 'all') {
|
|
return dir_list($self->root_dir, 'high_to_low', qr/^[0-9]{1,4}$/);
|
|
} elsif ($option eq 'new') {
|
|
return $self->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 $self = shift;
|
|
my ($dir) = $self->root_dir;
|
|
|
|
my ($mon, $year) = get_date('mon', 'year');
|
|
|
|
$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}$/);
|
|
|
|
return $year_files[0] if -T "$dir/$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]";
|
|
}
|
|
|
|
}
|
|
|
|
|
|
# Below replaces:
|
|
# my ($sec, $min, $hour, $mday, $mon,
|
|
# $year, $wday, $yday, $isdst) = localtime(time);
|
|
{
|
|
my %name_map = (
|
|
sec => 0, min => 1, hour => 2, mday => 3,
|
|
mon => 4, year => 5, wday => 6, yday => 5,
|
|
isdst => 6,
|
|
);
|
|
|
|
sub get_date {
|
|
my (@names) = @_;
|
|
my (@indices) = @name_map{@names};
|
|
my (@values) = (localtime time)[@indices];
|
|
return @values;
|
|
}
|
|
}
|
|
|
|
=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 $self = shift;
|
|
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--;
|
|
} else {
|
|
$month--;
|
|
}
|
|
|
|
until (-e $self->local_path("$year/$month")) {
|
|
|
|
if (! -d $self->local_path($year) ) {
|
|
# Give up easily, wrapping to newest month.
|
|
return $self->recent_month;
|
|
}
|
|
|
|
# handle January:
|
|
if ($month == 1) {
|
|
$month = 12; $year--;
|
|
next;
|
|
}
|
|
$month--;
|
|
}
|
|
|
|
return $cache{$this_month} = "$year/$month";
|
|
|
|
}
|
|
}
|
|
|
|
|
|
=item dir_list($dir, $sort_order, $pattern)
|
|
|
|
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, $pattern) = @_;
|
|
|
|
$pattern ||= qr/^[0-9]{1,2}$/;
|
|
$sort_order ||= 'high_to_low';
|
|
|
|
opendir my $list_dir, $dir
|
|
or die "Couldn't open $dir: $!";
|
|
|
|
my @files = sort $sort_order
|
|
grep { m/$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($year)
|
|
|
|
List out the updates for a year.
|
|
|
|
=cut
|
|
|
|
sub year {
|
|
my $self = shift;
|
|
my ($year) = @_;
|
|
|
|
my ($year_file, $year_url) = $self->root_locations($year);
|
|
|
|
# Year is a text file:
|
|
return $self->entry_wrapped($year) if -T $year_file;
|
|
|
|
# If it's not a directory, we can't do anything. Bail out:
|
|
return p('No such year.') if (! -d $year_file);
|
|
|
|
my $result;
|
|
|
|
# Handle year directories with index files.
|
|
$result .= $self->entry($year)
|
|
if -T "$year_file/index";
|
|
|
|
my $header_text = $self->icon_markup($year, $year);
|
|
$header_text ||= q{};
|
|
|
|
$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}$/
|
|
);
|
|
$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 $avg = int($count / @months);
|
|
$result .= p("$count entries, roughly $avg an active month.");
|
|
}
|
|
elsif ($count == 0) { $result .= p("$count entries"); }
|
|
elsif ($count == 1) { $result .= p("$count entry" ); }
|
|
|
|
return entry_markup($result);
|
|
}
|
|
|
|
=item month($month)
|
|
|
|
Prints the entries in a given month (nnnn/nn).
|
|
|
|
=cut
|
|
|
|
sub month {
|
|
my $self = shift;
|
|
my ($month) = @_;
|
|
|
|
my ($month_file, $month_url) = $self->root_locations($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.
|
|
if (-d $month_file) {
|
|
$result .= $self->entry($month)
|
|
if -T "$month_file/index";
|
|
|
|
my @entry_files = dir_list ($month_file, 'high_to_low',
|
|
qr/^[0-9]{1,2}$/);
|
|
|
|
foreach my $entry_file (@entry_files) {
|
|
$result .= entry_markup( $self->entry("$month/$entry_file")
|
|
. $self->datestamp("$month/$entry_file") );
|
|
}
|
|
|
|
} elsif (-T $month_file) {
|
|
$result .= $self->entry($month);
|
|
}
|
|
|
|
$result .= entry_markup(
|
|
p( 'class: navigation',
|
|
a('href: ' . $self->url_root . $self->month_before($month),
|
|
'title: previous month',
|
|
'⇐')
|
|
) . "\n\n"
|
|
);
|
|
|
|
return $result;
|
|
}
|
|
|
|
|
|
=item entry($entry)
|
|
|
|
Returns the contents of a given entry. Calls dir_list
|
|
and icon_markup. Recursively calls itself.
|
|
|
|
=item entry_wrapped
|
|
|
|
Wraps entry() in entry_markup.
|
|
|
|
=item entry_stamped
|
|
|
|
Wraps entry() + a datestamp in entry_markup()
|
|
|
|
=cut
|
|
|
|
sub entry_wrapped {
|
|
my $self = shift;
|
|
my ($entry, $level) = @_;
|
|
|
|
return entry_markup($self->entry($entry, $level));
|
|
}
|
|
|
|
sub entry_stamped {
|
|
my $self = shift;
|
|
my ($entry, $level) = @_;
|
|
|
|
return entry_markup(
|
|
$self->entry($entry, $level)
|
|
. $self->datestamp($entry)
|
|
);
|
|
}
|
|
|
|
sub entry {
|
|
my $self = shift;
|
|
my ($entry, $level) = @_;
|
|
$level ||= 'index';
|
|
|
|
# Location of entry on local filesystem, and its URL:
|
|
my ($entry_loc, $entry_url) = $self->root_locations($entry);
|
|
|
|
my $result;
|
|
|
|
# Display an icon, if we have one:
|
|
if ( my $ico_markup = $self->icon_markup($entry) ) {
|
|
$result .= heading($ico_markup, 2) . "\n\n";
|
|
}
|
|
|
|
# For text files:
|
|
if (-T $entry_loc) {
|
|
return $result . $self->fragment_slurp($entry_loc);
|
|
}
|
|
|
|
return $result if ! -d $entry_loc;
|
|
|
|
# Print index as head:
|
|
$result .= $self->fragment_slurp("$entry_loc/index");
|
|
|
|
# Followed by any sub-entries:
|
|
my @sub_entries = $self->get_sub_entries($entry_loc);
|
|
|
|
if (@sub_entries >= 1) {
|
|
if ($level eq 'index') {
|
|
# Icons or text links:
|
|
$result .= $self->list_contents($entry, @sub_entries);
|
|
}
|
|
elsif ($level eq 'all') {
|
|
# Everything in the directory:
|
|
foreach my $se (@sub_entries) {
|
|
next if ($se =~ $self->binfile_expr);
|
|
$result .= p('class: centerpiece', '+')
|
|
. $self->entry("$entry/$se");
|
|
}
|
|
}
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
sub get_sub_entries {
|
|
my $self = shift;
|
|
my ($entry_loc) = @_;
|
|
|
|
my %ignore = ('index' => 1);
|
|
|
|
return grep { ! $ignore{$_} }
|
|
dir_list($entry_loc, 'alpha', $self->entryfile_expr);
|
|
}
|
|
|
|
sub list_contents {
|
|
my $self = shift;
|
|
my ($entry) = shift;
|
|
my (@entries) = @_;
|
|
|
|
my $contents;
|
|
foreach my $se (@entries) {
|
|
my $linktext = $self->icon_markup("$entry/$se", $se);
|
|
$linktext ||= $se;
|
|
|
|
$contents .= q{ }
|
|
. a('href: ' . $self->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
|
|
|
|
{ my %cache;
|
|
sub icon_markup {
|
|
my $self = shift;
|
|
my ($entry, $alt) = @_;
|
|
|
|
if ($cache{$entry . $alt}) {
|
|
return $cache{$entry.$alt};
|
|
}
|
|
|
|
my ($entry_loc, $entry_url) = $self->root_locations($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";
|
|
}
|
|
|
|
# First suffix 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 $cache{$entry . $alt} =
|
|
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 $self = shift;
|
|
my ($entry) = @_;
|
|
|
|
my ($stamp);
|
|
if ( $entry =~ m{(^[0-9]{4}/[0-9]{1,2}/[0-9]{1,2})}x ) {
|
|
|
|
my ($entry_year, $entry_month, $entry_day) = split m{/}, $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 = ':: ';
|
|
my $wikititle;
|
|
|
|
if ($self->wala->is_page($wiki_date_name)) {
|
|
$wikititle = 'read the margins';
|
|
} else { $wikititle = 'write in the margins'; }
|
|
|
|
$wikistamp .= a("href: " . $self->wala->ScriptName . "?$wiki_date_name",
|
|
$wikititle,
|
|
'title: a page you can edit');
|
|
|
|
if ( -e $self->local_path($entry . "/NoMargin") ) {
|
|
$wikistamp = "<!-- Margin blocked. -->";
|
|
}
|
|
|
|
# Return a fancy datestamp:
|
|
|
|
my $month_name = month_name($entry_month);
|
|
my $year_url = "href: " . $self->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 $self = shift;
|
|
|
|
my ($file) = @_;
|
|
|
|
return q{} if (! -T $file);
|
|
|
|
# $file is text:
|
|
|
|
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}:
|
|
$self->eval_perl($everything);
|
|
|
|
# Take care of any special markup.
|
|
# We pass along $file so it has some context to work with
|
|
|
|
return $self->line_parse($everything, $file);
|
|
}
|
|
|
|
|
|
=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 from the keys to $self.
|
|
|
|
=cut
|
|
|
|
sub eval_perl {
|
|
my $self = shift;
|
|
|
|
while ($_[0] =~ m{<perl>(.*?)</perl>}s) {
|
|
my $block = $1;
|
|
|
|
# Run the $block, and include anything returned -
|
|
# or an error message, if we got one.
|
|
|
|
my $output = eval $block;
|
|
$output = $@ if $@;
|
|
$_[0] =~ s{<perl>\Q$block\E</perl>}{$output}s;
|
|
}
|
|
|
|
# Interpolate variables:
|
|
$_[0] =~ s/\${([a-zA-Z_]+)}/$self->{$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 root_locations($file)
|
|
|
|
Given a file/entry, return the appropriate concatenations with
|
|
root_dir and url_root.
|
|
|
|
=cut
|
|
|
|
sub root_locations {
|
|
return (
|
|
$_[0]->local_path($_[1]),
|
|
$_[0]->url_root . $_[1]
|
|
);
|
|
}
|
|
|
|
=item local_path
|
|
|
|
Return an absolute path for a given file. Called by root_locations.
|
|
|
|
Arguably this is stupid and inefficient.
|
|
|
|
=cut
|
|
|
|
sub local_path {
|
|
return $_[0]->root_dir . '/' . $_[1];
|
|
}
|
|
|
|
=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 $self = shift;
|
|
my ($month) = @_;
|
|
$month ||= $self->recent_month();
|
|
|
|
my $feed_url = $self->url_root . $self->feed_alias;
|
|
|
|
my ($month_file, $month_url) = $self->root_locations($month);
|
|
|
|
my $feed = XML::Atom::SimpleFeed->new(
|
|
title => $self->title,
|
|
link => $self->url_root,
|
|
link => { rel => 'self', href => $feed_url, },
|
|
icon => $self->favicon_url,
|
|
author => $self->author,
|
|
id => $self->url_root,
|
|
generator => 'Display.pm / XML::Atom::SimpleFeed',
|
|
);
|
|
|
|
my @entry_files;
|
|
|
|
if (-d $month_file) {
|
|
@entry_files = dir_list ($month_file,
|
|
'high_to_low',
|
|
qr/^[0-9]{1,2}$/);
|
|
} else {
|
|
return 0;
|
|
}
|
|
|
|
foreach my $entry_file (@entry_files) {
|
|
my $entry = "$month/$entry_file";
|
|
my $entry_url = $month_url . "/$entry_file";
|
|
|
|
$feed->add_entry(
|
|
title => $entry,
|
|
link => $entry_url,
|
|
id => $entry_url,
|
|
content => $self->entry($entry),
|
|
);
|
|
}
|
|
|
|
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;
|