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.
1036 lines
30 KiB
1036 lines
30 KiB
#!/usr/bin/perl
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
display - script to display fragments of text on the web and elsewhere
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
display started life as a way to concatenate fragments of handwritten HTML by
|
|
date. While the script has since haphazardly accumulated several of the usual
|
|
weblog features (comments, lightweight markup, feed generation, embedded Perl,
|
|
poetry tools, stupid dependencies), it hasn't changed much in six years. The
|
|
current version is intended to support FastCGI via CGI::Fast, if available, and
|
|
otherwise operate as a traditional CGI or commandline utility. It may have some
|
|
distance to go towards this goal.
|
|
|
|
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
|
|
|
|
use strict;
|
|
use warnings;
|
|
no warnings 'uninitialized';
|
|
|
|
use lib 'lib';
|
|
use lib 'wala';
|
|
|
|
use CGI::Fast;
|
|
use Image::Size;
|
|
use Text::Textile;
|
|
use XML::Atom::SimpleFeed;
|
|
use Wala qw (%WalaConf %DISPLAY_CONF);
|
|
|
|
# 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',
|
|
);
|
|
|
|
# Grab configuration:
|
|
if (-e 'conf.pl') {
|
|
do 'conf.pl';
|
|
}
|
|
|
|
$WalaConf{'ShowSearchlinks'} = 0;
|
|
|
|
# Handle input from FastCGI:
|
|
while (my $query = new CGI::Fast) {
|
|
handle($query);
|
|
}
|
|
|
|
# Fini.
|
|
|
|
=head1 SUBROUTINES
|
|
|
|
For no bigger than this thing is, it gets a little convoluted.
|
|
|
|
=over
|
|
|
|
=item handle()
|
|
|
|
Handle queries.
|
|
|
|
=cut
|
|
|
|
sub handle {
|
|
my ($query) = @_;
|
|
|
|
# Get the time, format the couple of variables I'll actually use.
|
|
my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday,
|
|
$isdst) = localtime(time);
|
|
$mon++;
|
|
$year += 1900;
|
|
|
|
# grab the command line options, using "new" if none are provided
|
|
#my @options = @ARGV;
|
|
#unless ($options[0]) { $options[0] = $ENV{'QUERY_STRING'} };
|
|
my @options = $query->param('keywords');
|
|
unless ($options[0]) { $options[0] = 'new' };
|
|
|
|
# now that we have some metadata,
|
|
# set some variables to be used in fragment interpretation.
|
|
# (these get inserted down in line_parse(); this is less than ideal)
|
|
$DISPLAY_CONF{title} = join(' ', @options);
|
|
|
|
# Unless this is already in an HTML document, spit out some default HTML.
|
|
my $print_footer = 0;
|
|
unless ($options[0] eq 'feed') {
|
|
print fragment_slurp($DISPLAY_CONF{HEADER});
|
|
$print_footer = 1;
|
|
}
|
|
|
|
# take care of "all" alias in options
|
|
# get everything in the archive root directory
|
|
my @old_options = @options;
|
|
for (@old_options) {
|
|
if ($_ eq 'all') {
|
|
push (@options, dir_list ($DISPLAY_CONF{ROOT_DIR},
|
|
"high_to_low",
|
|
"^[0-9]{1,4}\$") );
|
|
}
|
|
}
|
|
|
|
# do appropriate things:
|
|
|
|
foreach my $option (@options) {
|
|
|
|
# take care of trailing slashes
|
|
chop ($option) if (substr($option, -1, 1) eq '/');
|
|
|
|
# This just provides an alias for the most recent month.
|
|
if ($option =~ m/^(feed|new)/) {
|
|
my $special = $1;
|
|
|
|
if (-e "$DISPLAY_CONF{ROOT_DIR}/$year/$mon") {
|
|
$option = "$year/$mon";
|
|
} else {
|
|
$option = recent_month();
|
|
}
|
|
|
|
# Handle feed generation using XML::Atom::SimpleFeed.
|
|
if ($special eq 'feed') {
|
|
feed_print($option);
|
|
exit;
|
|
}
|
|
}
|
|
|
|
if ( $option =~ m'^[0-9/]{5,11}[a-z_/]+$' ) {
|
|
# nnnn/[nn/nn/]doc_name
|
|
# It's a document within a date. entry_print it.
|
|
print entry_markup(entry_print($option, 'index') . datestamp($option));
|
|
}
|
|
|
|
elsif ( $option =~ m'^[0-9]{4}/[0-9]{1,2}/[0-9]{1,2}$' ) {
|
|
# nnnn/nn/nn
|
|
# It's a specific date. Print it in full.
|
|
print 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.
|
|
month_print($option);
|
|
}
|
|
|
|
elsif ( $option =~ m'^[0-9]{4}$' ) {
|
|
# nnnn - It's a year. Display a list of entries.
|
|
year_print($option);
|
|
}
|
|
|
|
elsif ($option =~ m'^[a-z_]') {
|
|
# assume it's a document in the root directory
|
|
print entry_markup(entry_print($option, 'all'));
|
|
}
|
|
}
|
|
|
|
# Finish up...
|
|
# Print a footer.
|
|
if ($print_footer) {
|
|
print fragment_slurp($DISPLAY_CONF{FOOTER});
|
|
}
|
|
|
|
}
|
|
|
|
|
|
sub recent_month {
|
|
|
|
my (@year_files) = dir_list ("$DISPLAY_CONF{ROOT_DIR}",
|
|
'high_to_low',
|
|
'^[0-9]{1,4}$');
|
|
|
|
my (@month_files) = dir_list ("$DISPLAY_CONF{ROOT_DIR}/$year_files[0]",
|
|
'high_to_low',
|
|
'^[0-9]{1,2}');
|
|
|
|
return "$year_files[0]/$month_files[0]";
|
|
|
|
}
|
|
|
|
=item dir_list()
|
|
|
|
Return a $sort_order sorted list of files matching $pattern in a
|
|
directory. Called by year_print(), month_print(), and entry_print().
|
|
|
|
calls $sort_order, which can be one of
|
|
|
|
alpha - alphabetical
|
|
reverse_alpha - alphabetical, reversed (might not work yet)
|
|
high_to_low - numeric, high to low
|
|
low_to_high - numeric, low to high
|
|
|
|
=cut
|
|
|
|
sub dir_list {
|
|
my ($dir, $sort_order, $file_pattern) = @_;
|
|
my (@files);
|
|
|
|
$file_pattern = "^[0-9]{1,2}\$" unless ($file_pattern);
|
|
$sort_order = "high_to_low" unless ($sort_order);
|
|
|
|
opendir LIST_DIR, $dir;
|
|
@files = grep /$file_pattern/, readdir LIST_DIR;
|
|
closedir LIST_DIR;
|
|
|
|
@files = sort $sort_order @files;
|
|
|
|
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. Calls dir_list(), entry_print().
|
|
|
|
=cut
|
|
|
|
sub year_print {
|
|
my ($year) = @_;
|
|
my (@update_files, $update_count, $ico_markup);
|
|
|
|
if (-d "$DISPLAY_CONF{ROOT_DIR}/$year") {
|
|
print '<div class="entry">' . "\n";
|
|
|
|
if (-T "$DISPLAY_CONF{ROOT_DIR}/$year/index") {
|
|
print entry_print($year, 'index');
|
|
}
|
|
|
|
if ( $ico_markup = icon_markup($year, $year) ) {
|
|
print "<h3>$ico_markup $year</h3>";
|
|
} else {
|
|
print "<h3>$year</h3>\n";
|
|
}
|
|
|
|
my @month_files = dir_list ("$DISPLAY_CONF{ROOT_DIR}/$year",
|
|
"high_to_low",
|
|
"^[0-9]{1,2}\$");
|
|
|
|
print "\n<table>\n";
|
|
$update_count = 0;
|
|
foreach my $month_file (@month_files) {
|
|
@update_files = dir_list ("$DISPLAY_CONF{ROOT_DIR}/$year/$month_file",
|
|
"low_to_high", "^[0-9]{1,2}\$");
|
|
|
|
# Add the count of files to $update_count.
|
|
$update_count += @update_files;
|
|
|
|
print '<tr> <td class="datelink">'
|
|
. a("$DISPLAY_CONF{URL_ROOT}$year/$month_file", month_name($month_file))
|
|
. "</td> <td class=\"datelink\">\n";
|
|
|
|
print "( <small>";
|
|
|
|
foreach my $update_file (@update_files) {
|
|
print a("$DISPLAY_CONF{URL_ROOT}$year/$month_file/$update_file", $update_file)
|
|
. "\n";
|
|
}
|
|
print "</small> )</td> </tr>\n\n";
|
|
}
|
|
print "</table>\n";
|
|
|
|
print "<p>$update_count ";
|
|
if ($update_count > 1) {
|
|
my ($monthly_average) = int($update_count / @month_files);
|
|
print " entries, an arithmetic mean of $monthly_average a month.";
|
|
} elsif ($update_count == 0) {
|
|
print " entries";
|
|
} elsif ($update_count == 1) {
|
|
print " entry";
|
|
}
|
|
print '</p>';
|
|
|
|
} elsif (-T "$DISPLAY_CONF{ROOT_DIR}/$year") {
|
|
print entry_print($year, 'index');
|
|
} else {
|
|
print '<p>No such year.</p>';
|
|
}
|
|
print "</div>\n";
|
|
|
|
return ($update_count);
|
|
}
|
|
|
|
=item month_print()
|
|
|
|
Prints the entries in a given month (nnnn/nn). Calls dir_list(), datestamp().
|
|
|
|
=cut
|
|
|
|
sub month_print {
|
|
my ($year_digits, $month_digits, $calendar);
|
|
# 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 ($month) = @_;
|
|
|
|
if (-d "$DISPLAY_CONF{ROOT_DIR}/$month") {
|
|
if (-T "$DISPLAY_CONF{ROOT_DIR}/$month/index") {
|
|
print entry_print($month, "index");
|
|
}
|
|
|
|
my (@entry_files) = dir_list ("$DISPLAY_CONF{ROOT_DIR}/$month",
|
|
"high_to_low",
|
|
"^[0-9]{1,2}\$");
|
|
|
|
foreach my $entry_file (@entry_files) {
|
|
print entry_markup( entry_print("$month/$entry_file", 'index')
|
|
. datestamp("$month/$entry_file") );
|
|
}
|
|
} elsif (-T "$DISPLAY_CONF{ROOT_DIR}/$month") {
|
|
print entry_print($month, 'index');
|
|
}
|
|
}
|
|
|
|
=item entry_print()
|
|
|
|
Prints the contents of a given entry. Calls datestamp, fragment_print,
|
|
dir_list, and icon_markup. Recursively calls itself.
|
|
|
|
=cut
|
|
|
|
sub entry_print {
|
|
my ($entry, $level) = @_;
|
|
|
|
my ($result);
|
|
|
|
my $entry_loc = "$DISPLAY_CONF{ROOT_DIR}/$entry"; # location of entry on local filesystem
|
|
my $entry_url = $DISPLAY_CONF{URL_ROOT} . $entry; # and its URL
|
|
|
|
# display an icon, if we have one.
|
|
if ( my $ico_markup = icon_markup ($entry, "") ) {
|
|
$result .= "<h2>$ico_markup</h2>\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");
|
|
|
|
my @sub_entries = dir_list ($entry_loc, 'alpha',
|
|
'^[a-z_]+(\.tgz|\.zip|\.tar\.gz)?$');
|
|
|
|
# followed by any sub-entries
|
|
if ( ($level eq 'index') and (@sub_entries > 1) ) {
|
|
# if we're just supposed to print an index
|
|
# spit out icons or text links for extra files
|
|
my $contents;
|
|
my %ignore_entries = ("index" => 1, "standing_bear" => 1);
|
|
|
|
foreach my $sub_entry (@sub_entries) {
|
|
next if ($ignore_entries{$sub_entry});
|
|
|
|
if ( my $sub_ico_markup = icon_markup("$entry/$sub_entry",
|
|
$sub_entry) ) {
|
|
$contents .= qq|<a href="$DISPLAY_CONF{URL_ROOT}$entry/$sub_entry" |
|
|
. qq|title="$sub_entry">$sub_ico_markup</a>\n |;
|
|
} else {
|
|
$contents .= qq|<a href="$DISPLAY_CONF{URL_ROOT}$entry/$sub_entry "|
|
|
. qq|title="$sub_entry">$sub_entry</a> \n|;
|
|
}
|
|
}
|
|
|
|
$result .= "<p><em><strong>more</strong></em>: $contents</p>\n";
|
|
} elsif ( ($level eq 'all') and (@sub_entries > 1) ) {
|
|
|
|
# but if we're supposed to print everything in the directory
|
|
# and if there's more there than just the index file,
|
|
|
|
foreach my $sub_entry (@sub_entries) {
|
|
next if ($sub_entry eq 'index'); # skip index
|
|
|
|
# print each of the other files, separated by little headers
|
|
$result .= "\n\n<p class=\"centerpiece\">{"
|
|
. a("$DISPLAY_CONF{URL_ROOT}$entry/$sub_entry", $sub_entry)
|
|
. "}</p>\n\n";
|
|
|
|
# skipping any archives
|
|
next if ($sub_entry =~ m/(\.tgz|\.zip|\.tar\.gz)$/);
|
|
|
|
$result .= entry_print("$entry/$sub_entry", 'index');
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
=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
|
|
|
|
Called by entry_print, 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 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. Called by entry_print.
|
|
|
|
=cut
|
|
|
|
sub datestamp {
|
|
my ($entry, $markup_start, $markup_end) = @_;
|
|
|
|
unless ($markup_start and $markup_end) {
|
|
$markup_start = "\n<p class=\"datelink\">";
|
|
$markup_end = "</p>\n\n";
|
|
}
|
|
|
|
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 = qq{:: <a title="a page you can edit"}
|
|
. qq{ href="$WalaConf{ScriptName}?$wiki_date_name">read the margins</a>};
|
|
} else {
|
|
$wikistamp = qq{:: <a title="a page you can edit"}
|
|
. qq{ href="$WalaConf{ScriptName}?$wiki_date_name">write in the margins</a>};
|
|
}
|
|
|
|
# return a fancy datestamp.
|
|
|
|
my $month_name = month_name($entry_month);
|
|
$stamp = <<STAMP;
|
|
$markup_start
|
|
<a href="$DISPLAY_CONF{URL_ROOT}$entry_year" title="$entry_year">$entry_year</a>
|
|
<a href="$DISPLAY_CONF{URL_ROOT}$entry_year/$entry_month" title="$entry_year/$entry_month">$month_name</a>
|
|
<a href="$DISPLAY_CONF{URL_ROOT}$entry_year/$entry_month/$entry_day" title="$entry_year/$entry_month/$entry_day">$entry_day</a>
|
|
$wikistamp
|
|
$markup_end
|
|
STAMP
|
|
|
|
} else {
|
|
$stamp = "$markup_start(failed to construct datestamp for $entry)$markup_end";
|
|
}
|
|
|
|
return ($stamp);
|
|
}
|
|
|
|
=item fragment_print()
|
|
|
|
Print a text fragment - a header, footer, update, etc.
|
|
Called by main routines, used to print headers and footers.
|
|
Calls fragment_slurp to get the fragment it's supposed to print.
|
|
Returns 1 on successful completion, 0 otherwise.
|
|
|
|
=cut
|
|
|
|
sub fragment_print {
|
|
my ($file) = @_;
|
|
|
|
my $lines = fragment_slurp($file);
|
|
|
|
if (length($lines)) {
|
|
print $lines;
|
|
} else {
|
|
return '';
|
|
}
|
|
}
|
|
|
|
=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. Called by entry_print, at least
|
|
|
|
=cut
|
|
|
|
sub fragment_slurp {
|
|
my ($file) = @_;
|
|
|
|
# if $file is text
|
|
if (-T $file) {
|
|
my $everything;
|
|
|
|
open (my $fh, '<', $file) or return '';
|
|
{
|
|
# line sep
|
|
local $/ = undef;
|
|
$everything = <$fh>;
|
|
}
|
|
close $fh;
|
|
|
|
# take care of any special markup
|
|
# we feed $file to line_parse so it has some context to work with
|
|
$everything = line_parse ($file, $everything);
|
|
|
|
return $everything;
|
|
} else {
|
|
return '';
|
|
}
|
|
}
|
|
|
|
=item line_parse()
|
|
|
|
Performs substitutions on lines called by fragment_slurp, at least. Calls
|
|
image_markup, Text::Textile, Wala::wiki_page_to_html, eval_perl. Returns
|
|
string.
|
|
|
|
Parses some special markup, specifically:
|
|
|
|
<perl>embedded perl</perl>
|
|
${variable} interpolation from %DISPLAY_CONF
|
|
<textile></textile> - Text::Textile to HTML
|
|
<wala></wala> - Wala::wikify();
|
|
<image>filename.ext</image>
|
|
<freeverse></freeverse>
|
|
<retcon></retcon>
|
|
<list></list>
|
|
|
|
=cut
|
|
|
|
sub line_parse {
|
|
my ($file, $everything) = (@_);
|
|
|
|
# eval embedded Perl
|
|
$everything = eval_perl($everything, $file);
|
|
|
|
# interpolate variables
|
|
$everything =~ s/\${([a-zA-Z_]+)}/$DISPLAY_CONF{$1}/ge;
|
|
|
|
# take care of wala markup
|
|
$everything =~ s/<wala>(.*?)<\/wala>/Wala::wikify($1)/seg;
|
|
|
|
# take care of textile markup, if we've got any
|
|
# this is wrapped in a conditional to keep from
|
|
# creating the object if we don't need it.
|
|
if ($everything =~ m/<textile>/s) {
|
|
# head_offset: use h1., h2. in Textile formatting.
|
|
my $textile = Text::Textile->new( head_offset => 2 );
|
|
|
|
$everything =~ s/<textile>(.*?)<\/textile>/$textile->process($1)/seg;
|
|
}
|
|
|
|
# evaluate <image> tags.
|
|
$everything =~ s!<image>(.*?)</image>!image_markup($file, $1)!seg;
|
|
|
|
my %tags = ( retcon => 'div class="retcon"',
|
|
freeverse => 'p',
|
|
list => "ul>\n<li" );
|
|
|
|
my %end_tags = ( retcon => 'div',
|
|
freeverse => 'p',
|
|
list => 'li></ul' );
|
|
|
|
my %blank_lines = ( freeverse => "</p>\n\n<p>",
|
|
list => "</li>\n\n<li>" );
|
|
|
|
my %newlines = ( freeverse => "<br />\n" );
|
|
|
|
my %dashes = ( freeverse => ' — ' );
|
|
|
|
foreach my $key (keys %tags) {
|
|
# Set some replacements, unless they've been explicitly set already.
|
|
$end_tags{$key} = $tags{$key} unless $end_tags{$key};
|
|
$blank_lines{$key} = "\n\n" unless $blank_lines{$key};
|
|
$newlines{$key} = "\n" unless $newlines{$key};
|
|
$dashes{$key} = " -- " unless $dashes{$key};
|
|
|
|
while ($everything =~ m/(<$key>.*?<\/$key>)/s) {
|
|
my $block = $1;
|
|
|
|
# save the bits between instances of the block --
|
|
# the \Q and \E escape any regex chars in the block
|
|
my (@interstice_array) = split (/\Q$block\E/s, $everything);
|
|
|
|
# now, transform the contents of the block we've found:
|
|
|
|
# tags that surround the block
|
|
$block =~ s/\n?<$key>\n?/<$tags{$key}>/gs;
|
|
$block =~ s!\n?</$key>\n?!</$end_tags{$key}>!gs;
|
|
|
|
# dashes
|
|
$block =~ s/(\s+)\-{2}(\s+)/$1$dashes{$key}$2/gs;
|
|
|
|
# blank lines within the block
|
|
$block =~ s/\n\n/$blank_lines{$key}/gs;
|
|
|
|
# single newlines (i.e., line ends) within the block
|
|
# except those preceded by a double-quote, which probably
|
|
# indicates a still-open tag.
|
|
$block =~ s/([^"\n])\n([^\n])/$1$newlines{$key}$2/gs;
|
|
|
|
# and slap it all back together as $everything
|
|
$everything = join $block, @interstice_array;
|
|
|
|
}
|
|
}
|
|
|
|
return $everything;
|
|
}
|
|
|
|
=item eval_perl()
|
|
|
|
Evaluate embedded Perl, replacing blocks enclosed with <perl> tags
|
|
with whatever they return (well, evaluated in a scalar context).
|
|
|
|
=cut
|
|
|
|
sub eval_perl {
|
|
my ($everything, $file) = @_;
|
|
|
|
while ($everything =~ m/<perl>(.*?)<\/perl>/s) {
|
|
my $block = $1;
|
|
|
|
my $output = eval $block;
|
|
if ($@) {
|
|
# got an error
|
|
$everything =~ s/<perl>\Q$block\E<\/perl>/$@ in $file/s;
|
|
} else {
|
|
# include anything returned from $block
|
|
$everything =~ s/<perl>\Q$block\E<\/perl>/$output/s;
|
|
}
|
|
}
|
|
|
|
return $everything;
|
|
}
|
|
|
|
|
|
=item image markup()
|
|
|
|
Parse out an image tag and return the appropriate html. Calls image_size.
|
|
Called by line_parse.
|
|
|
|
=cut
|
|
|
|
sub image_markup {
|
|
my ($file, $block) = @_;
|
|
|
|
# get a directory for the file we're working with
|
|
$file =~ s'[^/]* # everything not a /
|
|
$ # up to end of string
|
|
''x;
|
|
|
|
# truncated file date that just includes date + sub docs
|
|
my ($file_date) = $file =~ m'([0-9]{4}/[0-9]{1,2}/[0-9]{1,2}/([a-z]*/)*)$';
|
|
|
|
my ($image_name, $alt_text) = split/\n/, $block;
|
|
|
|
my $image_file;
|
|
if (-e "$file/$image_name" ) {
|
|
$image_file = "$file/$image_name";
|
|
$image_name = "${file_date}${image_name}";
|
|
} elsif (-e "$DISPLAY_CONF{ROOT_DIR}/$image_name") {
|
|
$image_file = "$DISPLAY_CONF{ROOT_DIR}/$image_name";
|
|
}
|
|
|
|
# get width & height in pixels for known filetypes
|
|
my ($width, $height) = image_size($image_file);
|
|
|
|
# may need to change this if rewrites don't work
|
|
return qq|<img src="$DISPLAY_CONF{IMAGE_URL_ROOT}$image_name"\n height="$height"|
|
|
. qq|\n width="$width"\n alt="$alt_text" />|;
|
|
}
|
|
|
|
|
|
=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()
|
|
|
|
Dump out an Atom feed of entries for a month.
|
|
|
|
Called from handle(), calls entry_print, requires XML::Atom::SimpleFeed.
|
|
|
|
=cut
|
|
|
|
sub feed_print {
|
|
my $month = shift;
|
|
|
|
# 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},
|
|
);
|
|
|
|
# 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',
|
|
"^[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", 'index');
|
|
|
|
$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,
|
|
);
|
|
|
|
}
|
|
|
|
print "Content-type: application/atom+xml\n\n";
|
|
$feed->print;
|
|
return 1;
|
|
|
|
}
|
|
|
|
|
|
=item entry_markup()
|
|
|
|
Return text wrapped in the appropriate markup for an entry. Just a wrapper
|
|
around div() at the moment.
|
|
|
|
=cut
|
|
|
|
sub entry_markup {
|
|
my ($text) = @_;
|
|
return div($text, 'entry');
|
|
}
|
|
|
|
|
|
=item div()
|
|
|
|
Return text wrapped in a div of the specified class.
|
|
|
|
=cut
|
|
|
|
sub div {
|
|
my ($text, $class) = @_;
|
|
my ($top, $result);
|
|
|
|
if ($class) {
|
|
$top = "<div class=\"$class\">\n";
|
|
} else {
|
|
$top = "<div>\n";
|
|
}
|
|
|
|
return ( $top . $text . "\n</div>\n" );
|
|
}
|
|
|
|
|
|
=item a()
|
|
|
|
Returns an HTML link. Called all over the place.
|
|
|
|
=cut
|
|
|
|
sub a {
|
|
my ($url, $text) = @_;
|
|
return "<a href=\"$url\">$text</a>";
|
|
}
|
|
|
|
|
|
=item ornament()
|
|
|
|
Returns a type ornament.
|
|
|
|
=cut
|
|
|
|
sub ornament {
|
|
return '<small>§</small>';
|
|
}
|
|
|
|
|
|
=item image_size()
|
|
|
|
Returns (width, height) of a variety of image files. Called by icon_markup and
|
|
line_parse. Uses Image::Size if available, otherwise uses a couple of built-in
|
|
routines munged together from pngsize and jpegsize in wwwis, by Alex Knowles
|
|
and Andrew Tong.
|
|
|
|
=cut
|
|
|
|
sub image_size {
|
|
my ($image_file) = shift;
|
|
|
|
# Use Image::Size - this needs to be actually conditionalized.
|
|
|
|
my ($x, $y, $type);
|
|
($x, $y, $type) = imgsize($image_file);
|
|
return ($x, $y);
|
|
|
|
# Otherwise we want to use our built-in routines:
|
|
|
|
my ($head);
|
|
|
|
if ( !open(IMAGE, '<', $image_file) ) {
|
|
print STDERR "can't open IMG $image_file";
|
|
return (0, 0);
|
|
} else {
|
|
binmode IMAGE;
|
|
if ($image_file =~ m/\.png$/) { # it's a PNG
|
|
my ($a, $b, $c, $d, $e, $f, $g, $h) = 0;
|
|
|
|
if (defined($image_file)
|
|
&& read(IMAGE, $head, 8) == 8
|
|
&& ($head eq "\x8a\x4d\x4e\x47\x0d\x0a\x1a\x0a" ||
|
|
$head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a")
|
|
&& read(IMAGE, $head, 4) == 4
|
|
&& read(IMAGE, $head, 4) == 4
|
|
&& ($head eq "MHDR" || $head eq "IHDR")
|
|
&& read(IMAGE, $head, 8) == 8) {
|
|
# ($x, $y) = unpack("I"x2, $head);
|
|
# doesn't work on little-endian machines
|
|
# return ($x,$y);
|
|
($a,$b,$c,$d,$e,$f,$g,$h) = unpack ("C"x8, $head);
|
|
return ($a<<24|$b<<16|$c<<8|$d, $e<<24|$f<<16|$g<<8|$h);
|
|
}
|
|
} elsif ($image_file =~ m/\.jpe?g$/) { # it's a JPEG
|
|
my($done) = 0;
|
|
my($c1,$c2,$ch,$s,$length, $dummy) = (0,0,0,0,0,0);
|
|
my($a,$b,$c,$d);
|
|
|
|
if (defined($image_file)
|
|
&& read(IMAGE, $c1, 1)
|
|
&& read(IMAGE, $c2, 1)
|
|
&& ord($c1) == 0xFF
|
|
&& ord($c2) == 0xD8) {
|
|
while (ord($ch) != 0xDA && !$done) {
|
|
# Find next marker (JPEG markers begin with 0xFF)
|
|
# This can hang the program!!
|
|
while (ord($ch) != 0xFF) {
|
|
return(0,0) unless read(IMAGE, $ch, 1);
|
|
}
|
|
|
|
# JPEG markers can be padded with unlimited 0xFF's
|
|
while (ord($ch) == 0xFF) {
|
|
return(0,0) unless read(IMAGE, $ch, 1);
|
|
}
|
|
|
|
# Now, $ch contains the value of the marker.
|
|
if ((ord($ch) >= 0xC0) && (ord($ch) <= 0xC3)) {
|
|
return(0,0) unless read (IMAGE, $dummy, 3);
|
|
return(0,0) unless read(IMAGE, $s, 4);
|
|
($a,$b,$c,$d)=unpack("C"x4,$s);
|
|
return ($c<<8|$d, $a<<8|$b );
|
|
} else {
|
|
# We **MUST** skip variables, since FF's within
|
|
# variable names are NOT valid JPEG markers
|
|
return(0,0) unless read (IMAGE, $s, 2);
|
|
($c1, $c2) = unpack("C"x2,$s);
|
|
$length = $c1<<8|$c2;
|
|
last if (!defined($length) || $length < 2);
|
|
read(IMAGE, $dummy, $length-2);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return (0,0);
|
|
}
|
|
}
|
|
|
|
=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;
|