wrt/Display.pm

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;