|
|
- package Display;
-
- our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x;
- # $Author$
- # $Date$
- # $Id$
-
- 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 default values
-
- =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()
-
- =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.
-
- =cut
-
- # 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().
-
- sub handle {
- my $self = shift;
- my ($option) = @_;
-
- # Dispatch entries to output routines:
-
- my $output;
- my %map = %{ $self->entry_map };
-
- while ( my ($pattern, $dispatch) = each %map ) {
- if ($option =~ $pattern) {
- $output .= $dispatch->($self, $option);
- last;
- }
- }
-
- return $output;
-
- }
-
-
- =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{/};
-
- 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 .= p( 'class: centerpiece',
- a('href: ' . $self->url_root . $self->month_before($month),
- 'previous')
- ) . "\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');
-
-
- # 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)
-
- =item
-
- 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;
|