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.
1775 lines
45 KiB
1775 lines
45 KiB
#!/usr/bin/perl
|
|
# vim:set ts=2 et:
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
Wala.pm - easy minimalist wiki
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
As a standalone wiki app:
|
|
|
|
#!/usr/bin/perl
|
|
use Wala;
|
|
my $w = Wala->new;
|
|
$w->run;
|
|
|
|
Pulling content into other scripts:
|
|
|
|
$text = $w->print_page('SandBox');
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This is a Wala, which is a derivation of a wiki that incorporates appending
|
|
text directly to pages, turning a wiki into something more like a forum while
|
|
retaining all the wonderful full-page editing features of a wiki.
|
|
|
|
=head1 INSTALLATION
|
|
|
|
This script is a self-contained package, which makes the code easy to test.
|
|
To actually use it as a wala, create a script named "wala.pl" in the same
|
|
directory, containing the following three lines:
|
|
|
|
#!/usr/bin/perl
|
|
use Wala;
|
|
my $w = Wala->new();
|
|
$w->run;
|
|
|
|
You can experiment with the wala by use'ing it and calling its functions
|
|
without calling "run". By default, required directories and files should
|
|
be created as needed, but you can visit wala.pl?setup in your browser,
|
|
or call C<setup()> from a script at any time.
|
|
|
|
=head2 CONFIGURATION
|
|
|
|
You can set options directly from the calling script, like so:
|
|
|
|
#!/usr/bin/perl
|
|
use Wala;
|
|
|
|
my $w = Wala->new(
|
|
RecentChangesMaxLines => 50, # Max lines to display in RecentChanges
|
|
DefaultUserName => 'Anonymous', # Default user name
|
|
StyleSheet => 'wala.css', # URL of style sheet
|
|
DefaultPageText => "Write something.\n",
|
|
CookieSurvivalDays => 90, # Number of days for cookies to remain
|
|
RootDir => '.', # No trailing slash, please
|
|
HomePage => 'HomePage', # Name of default page
|
|
TimeZone => 'UTC', # Currently just a string to display
|
|
TitleString => 'wala::', # Display before page names in titles
|
|
ScriptName => 'wala.pl',
|
|
ShowSearchlinks => 1, # Display "see also" box on pages
|
|
CheckSetup => 1, # Check for setup files every time
|
|
UseCache => 0, # Don't use caching behavior
|
|
);
|
|
|
|
$w->run;
|
|
|
|
=head2 FEEDS
|
|
|
|
Feeds are practically a requirement these days. While it wouldn't be the
|
|
hardest thing in the world to roll my own Atom or RSS within Wala.pm, it was
|
|
much less painful to look to CPAN, which offers XML::Atom::SimpleFeed.
|
|
|
|
I've included a simple wala_feed.pl, which relies on the aforementioned
|
|
module. It shouldn't be too hard to customize.
|
|
|
|
If you do something along the lines of:
|
|
|
|
FeedURL => 'http://p1k3.com/wala/wala_feed.pl',
|
|
|
|
in your configuration, Wala.pm will link to your feed in page headers so that
|
|
browsers like Firefox will auto-discover it.
|
|
|
|
=head1 LICENSE
|
|
|
|
No warranty of any kind is made regarding this software's fitness or
|
|
suitability for any purpose. The authors explicitly disclaim any liability or
|
|
responsibility for the results of its use.
|
|
|
|
This software is dedicated to the public domain. In any jurisdiction where a
|
|
dedication to the public domain is not permitted by law, the authors grant you
|
|
a perpetual, non-exclusive license to modify and/or redistribute the software
|
|
in any medium, world-wide, forever and ever.
|
|
|
|
Though there is no legal requirement, credit would be appreciated.
|
|
|
|
=head1 AUTHORS
|
|
|
|
Wala was originally written by Brent P. Newhall. This version contains
|
|
substantial modifications by Brennen Bearnes; following Brent's lead, all
|
|
changes are placed in the public domain. Egregious bugs are probably Brennen's
|
|
fault.
|
|
|
|
=head1 REVISION
|
|
|
|
Brennen's version, branched from Brent's at 1.1.4
|
|
Last updated Thu Jun 7 13:45:31 PDT 2007
|
|
|
|
=cut
|
|
|
|
package Wala;
|
|
|
|
use strict;
|
|
use warnings;
|
|
no warnings 'uninitialized';
|
|
|
|
use Fcntl qw(:flock);
|
|
use POSIX qw(strftime);
|
|
|
|
# Pull in the markup package.
|
|
use Wala::Markup;
|
|
use Wala::Editor;
|
|
|
|
# Default configuration:
|
|
my %WalaConf = (
|
|
RecentChangesMaxLines => 50, # Max lines to display in RecentChanges
|
|
DefaultUserName => 'Anonymous', # Default user name
|
|
StyleSheet => 'wala.css', # URL of style sheet
|
|
DefaultPageText => "Write something.\n",
|
|
CookieSurvivalDays => 90, # Number of days for cookies to remain
|
|
RootDir => '.', # No trailing slash, please
|
|
HomePage => 'HomePage', # Name of default page
|
|
TimeZone => 'UTC', # Currently just a string to display
|
|
TitleString => 'wala::', # Display before page names in titles
|
|
ScriptName => 'wala.pl', # substr( $0, rindex( $0, "/" ) + 1 );
|
|
ShowSearchlinks => 1, # Display "see also" box on pages
|
|
CheckSetup => 1, # Check for setup files every time
|
|
UseCache => 0, # Don't use caching behavior
|
|
DisplayRootDir => undef,
|
|
DisplayURL => undef,
|
|
TestMode => undef,
|
|
FeedURL => undef,
|
|
cookies => undef,
|
|
parameters => undef,
|
|
);
|
|
|
|
# The following bits are cheap method generation, in place
|
|
# of using Class::Accessor or Object::Tiny.
|
|
{
|
|
no strict 'refs';
|
|
|
|
# These are simple accessors.
|
|
foreach my $name (keys %WalaConf) {
|
|
# Install a generated sub:
|
|
*{ $name } = makemethod($name);
|
|
}
|
|
|
|
# These are conditional accessors, dependent on RootDir.
|
|
my %methods_rootdir = (
|
|
LogFile => 'log',
|
|
SpamLogFile => 'spam.log',
|
|
PagesDir => 'pages',
|
|
CacheDir => 'cache',
|
|
DiffDir => 'diffs',
|
|
);
|
|
|
|
foreach my $name (keys %methods_rootdir) {
|
|
# Install a generated sub:
|
|
*{ $name } = makemethod_rootdir($name, $methods_rootdir{$name});
|
|
}
|
|
|
|
}
|
|
|
|
# Handy-dandy basic closure:
|
|
sub makemethod {
|
|
my ($name) = @_;
|
|
|
|
return sub {
|
|
my ($self, $param) = @_;
|
|
$self->{$name} = $param if $param;
|
|
return $self->{$name};
|
|
}
|
|
}
|
|
|
|
# A slightly more complicated closure.
|
|
# If we don't have an appropriate value,
|
|
# return the RootDir + a default.
|
|
#
|
|
# This way, if we haven't explicitly set
|
|
# something like LogFile, it will always
|
|
# be dependent on RootDir.
|
|
sub makemethod_rootdir {
|
|
my ($name, $default) = @_;
|
|
|
|
return sub {
|
|
my $self = shift;
|
|
my ($param) = @_;
|
|
|
|
if (defined $param) {
|
|
$self->{$name} = $param;
|
|
}
|
|
|
|
if (defined $self->{$name}) {
|
|
return $self->{$name};
|
|
} else {
|
|
return $self->RootDir . "/$default";
|
|
}
|
|
}
|
|
}
|
|
|
|
=head1 METHODS
|
|
|
|
=over
|
|
|
|
=item new()
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my ($class) = shift;
|
|
my (@params) = @_;
|
|
|
|
my $self = \%WalaConf;
|
|
bless $self, $class;
|
|
|
|
$self->conf(@params);
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub conf {
|
|
my $self = shift;
|
|
my %params = @_;
|
|
|
|
for my $p (keys %params) {
|
|
$self->{$p} = $params{$p};
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
=item run()
|
|
|
|
=cut
|
|
|
|
sub run {
|
|
my $self = shift;
|
|
my ($query, $result);
|
|
|
|
my $page = $self->HomePage;
|
|
$self->setup() if $self->CheckSetup;
|
|
$self->parse_cookies($ENV{'HTTP_COOKIE'});
|
|
|
|
my $querystring = $ENV{'QUERY_STRING'};
|
|
my $content_len = $ENV{'CONTENT_LENGTH'};
|
|
|
|
if (length($querystring) > 0 and index($querystring, '=') < 0) {
|
|
# We got a plain WikiWord as the only parameter, so that's the page
|
|
$page = $querystring;
|
|
} elsif (length($querystring) > 0 or $content_len > 0) {
|
|
|
|
# We have one or more parameters; read and parse them:
|
|
|
|
if ($content_len > 0) {
|
|
read STDIN, $query, $content_len;
|
|
} else {
|
|
$query = $querystring;
|
|
}
|
|
|
|
$result = $self->parse_parameters($query, $page);
|
|
}
|
|
|
|
# Cut off access to other directories.
|
|
if (substr($page, 0, 1) eq '.') {
|
|
$page = $self->HomePage;
|
|
}
|
|
|
|
my $pagefile = $self->PagesDir . "/$page";
|
|
my $cachefile = $self->CacheDir . "/$page";
|
|
|
|
print $self->get_header($page);
|
|
|
|
# We're faking a stupid global here:
|
|
my $parameters = $self->parameters;
|
|
|
|
if ($result) {
|
|
# take care of the results from various parameters
|
|
print $result . "\n</body>\n</html>\n";
|
|
return 1; # done
|
|
} elsif ($parameters->{'action'} eq 'links') {
|
|
# A bit of a special case - show all backlinks:
|
|
print $self->print_page($page) . $self->get_footer($page);
|
|
return 1; # done
|
|
}
|
|
|
|
# Half of caching behavior is implemented starting here:
|
|
|
|
CACHEBREAK: {
|
|
my $usecache = $self->UseCache;
|
|
|
|
if ( $page =~ m/^([A-Z]|PageIndex|RecentChanges|HomePage|
|
|
PageChangeTimes)$/x ) {
|
|
$usecache = 0;
|
|
}
|
|
|
|
# Why was this localized? Does it matter?
|
|
#local $WalaConf{UseCache} = $usecache;
|
|
|
|
unless ($usecache) {
|
|
print $self->print_page($page) . $self->get_footer($page);
|
|
return 1; # done
|
|
}
|
|
}
|
|
|
|
# Only fall through to this stuff if UseCache is turned on:
|
|
|
|
my ($page_mtime, $cachetime);
|
|
|
|
if (-e $cachefile) {
|
|
($page_mtime, $cachetime) = get_mtime($pagefile, $cachefile);
|
|
}
|
|
|
|
# Has the page been touched since it was cached?
|
|
if ($page_mtime < $cachetime) {
|
|
# use cache
|
|
$result = get_file_text($cachefile);
|
|
} else {
|
|
# otherwise store a copy in the cache
|
|
$result = $self->print_page($page);
|
|
write_file($cachefile, $result);
|
|
}
|
|
|
|
print $result . $self->get_footer($page);
|
|
|
|
}
|
|
|
|
|
|
#######################
|
|
# Markup Processing #
|
|
#######################
|
|
|
|
# Pass the page out to a markup plugin, then pull it back in
|
|
# and handle links.
|
|
|
|
sub wikify {
|
|
my $self = shift;
|
|
my ($page) = @_;
|
|
|
|
# Get our markup.
|
|
# So far just the default Wala module.
|
|
$page = Wala::Markup::wiki_page_to_html($page);
|
|
|
|
# this to use Textile
|
|
#my $textile = new Text::Textile;
|
|
#$page = $textile->process($page);
|
|
|
|
$page = $self->convert_links($page);
|
|
$page = $self->convert_wikiwords($page);
|
|
$page = $self->handle_macros($page);
|
|
|
|
return $page;
|
|
|
|
}
|
|
|
|
|
|
# Right now this just handles {pageindex} and {recentchanges}
|
|
# for &wikify
|
|
sub handle_macros {
|
|
my $self = shift;
|
|
my ($page) = @_;
|
|
|
|
# This is stupid. Note particularly the <p> tags.
|
|
|
|
$page =~ s/<p>
|
|
{recentchanges\ +(\d+)}
|
|
<\/p>
|
|
/$self->print_recent_changes($1)/geosix;
|
|
|
|
$page =~ s/<p>
|
|
{pageindex}
|
|
<\/p>
|
|
/$self->get_list_of_pages()/geosix;
|
|
|
|
return $page;
|
|
|
|
}
|
|
|
|
|
|
#######################
|
|
# Link Processing #
|
|
#######################
|
|
|
|
# Return link markup.
|
|
sub a {
|
|
my ($url, $linktext, $class) = @_;
|
|
$class ||= 'exists';
|
|
return qq{<a href="$url" class="$class">$linktext</a>};
|
|
}
|
|
|
|
|
|
sub convert_links {
|
|
my $self = shift;
|
|
my ($text) = @_;
|
|
|
|
# Bare links.
|
|
$text =~ s/(?<![\[<]) # not preceded by
|
|
(http|https|ftp|gopher|news|telnet|ssh):\/\/ # protocol
|
|
[A-Za-z0-9\/\.\-\=\?\&\%\~\_\+#]* # text
|
|
/get_link($&)/geosx;
|
|
|
|
|
|
# Bracketed links. This one could perhaps use some work.
|
|
$text =~ s/\[ # start bracket
|
|
(http|https|ftp|gopher|news|telnet|ssh):\/\/ # protocol
|
|
[\s\S]*? # whitespace?
|
|
\] # end bracket
|
|
/get_bracketed_link($&)/geosx;
|
|
|
|
|
|
$text =~ s/mailto:*\S+/get_email_link($&)/geos;
|
|
|
|
return $text;
|
|
}
|
|
|
|
|
|
# Bracketed URLs, with or without link text following.
|
|
sub get_bracketed_link {
|
|
my ($text) = @_;
|
|
|
|
$text = substr($text, 1, length($text) - 2);
|
|
my $posit = index($text, ' ');
|
|
|
|
if ($posit >= 0) {
|
|
return a(
|
|
substr($text, 0, $posit),
|
|
substr($text, $posit + 1),
|
|
'external'
|
|
);
|
|
} else {
|
|
return a($text, $text, 'external');
|
|
}
|
|
}
|
|
|
|
|
|
sub get_link {
|
|
my ($url) = @_;
|
|
|
|
if ( is_image($url) ) {
|
|
return qq{<img src="$url" alt="(image)" />};
|
|
} else {
|
|
# Chop down the URL for display - no protocol:
|
|
my $url_stub = $url;
|
|
$url_stub =~ s{^.*?://(.*)$}{$1};
|
|
return a($url, $url_stub, 'external');
|
|
}
|
|
}
|
|
|
|
# For now, this just tests on file extension.
|
|
sub is_image {
|
|
my ($url) = @_;
|
|
|
|
if ($url =~ m{^(http:|https:|ftp:) # protocol
|
|
[A-Za-z0-9/.\-=?&%~_+]+
|
|
\.(gif|jpg|jpeg|png$) # extensions
|
|
}ix )
|
|
{
|
|
return 1;
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
|
|
# This could be smarter.
|
|
sub get_email_link {
|
|
my ($mailto) = @_;
|
|
return a($mailto, $mailto, 'external');
|
|
}
|
|
|
|
############################
|
|
# Wiki Word Processing #
|
|
############################
|
|
|
|
sub convert_wikiwords {
|
|
my $self = shift;
|
|
my ($text) = @_;
|
|
|
|
# CamelCase
|
|
$text =~ s/(?<![A-Za-z0-9\[\=\/\?\.\,\&\-]) # if not preceeded by
|
|
([A-Z][a-z0-9]+) # One uppercase + lowercase
|
|
([A-Z][a-z0-9]+)+ # + one uppercase + lowercase
|
|
/$self->wikiword_linkify($&)/geosx;
|
|
|
|
# Bracketed links
|
|
$text =~ s!\[{1,2} # one or two brackets
|
|
([A-Za-z0-9|.%,_'\!\ ]*) # everything we take in the link
|
|
\]{1,2} # one or two brackets
|
|
!$self->wikiword_linkify($1)!geosx;
|
|
|
|
return $text;
|
|
}
|
|
|
|
|
|
sub wikiword_linkify {
|
|
my $self = shift;
|
|
my ($wikiword) = @_;
|
|
|
|
my $label = $wikiword;
|
|
if ($wikiword =~ m/^(.*)\|(.*)$/) {
|
|
($wikiword, $label) = ($1, $2);
|
|
}
|
|
|
|
# take care of spaces by turning them into underscores
|
|
$wikiword =~ s/ /_/g;
|
|
|
|
my $scriptname = $self->ScriptName;
|
|
|
|
if( $self->is_page($wikiword) ) {
|
|
return a($scriptname . "?$wikiword", $label);
|
|
} else {
|
|
return a($scriptname . "?action=edit&id=$wikiword",
|
|
$label, 'new');
|
|
}
|
|
}
|
|
|
|
|
|
##########################
|
|
# Webpage Processing #
|
|
##########################
|
|
|
|
sub write_page {
|
|
my $self = shift;
|
|
my ($pagename, $file_text, $summary, $old_timestamp) = @_;
|
|
|
|
# Test for anonymous users attempting to use URLs
|
|
if ( $self->spamcheck($file_text, $pagename, $summary) ) {
|
|
# Do nothing further.
|
|
return 0;
|
|
}
|
|
|
|
# Check for edit collisions:
|
|
my $new_timestamp = get_mtime($self->PagesDir . "/$pagename");
|
|
if( $old_timestamp and ($new_timestamp > $old_timestamp) ) {
|
|
return "<h1>Probable edit collision.</h1>\n\n<p>This page has changed
|
|
since you started editing it. You'll find your text below the
|
|
edit box - please incorporate your changes here and save the
|
|
new version."
|
|
. $self->edit_form($pagename)
|
|
. "<h1>your text</h1>\n\n$file_text";
|
|
}
|
|
|
|
# Write the diff, and return a one-line summary.
|
|
my $diff_line = $self->write_diff($pagename, $file_text);
|
|
$summary ||= $diff_line;
|
|
|
|
# Write the new page and log it.
|
|
write_file($self->PagesDir . "/$pagename", $file_text);
|
|
$self->log_page_edit($pagename, $summary, $self->get_username);
|
|
|
|
# Bail out unless caching is turned on:
|
|
return 0 unless ($self->UseCache);
|
|
|
|
my @to_touch;
|
|
|
|
# For new pages we want to update anything that links here:
|
|
if ($diff_line eq 'New page or unchanged.') {
|
|
@to_touch = $self->get_linked_pages($pagename, 0);
|
|
}
|
|
|
|
# Update everything this page links to:
|
|
push @to_touch, pagelinks($file_text);
|
|
|
|
my $touch_time = time;
|
|
|
|
# touch appropriate files,
|
|
# first mapping directory prefix to the list.
|
|
my $pagesdir = $self->PagesDir;
|
|
utime $touch_time, $touch_time,
|
|
map { "${pagesdir}$_" } @to_touch;
|
|
|
|
return (0);
|
|
}
|
|
|
|
|
|
# Is there a good chance this is spam?
|
|
# This is a very, very naive mechanism, but it mostly seems to work.
|
|
sub spamcheck {
|
|
my $self = shift;
|
|
my ($text, $pagename, $summary) = @_;
|
|
|
|
# Does the file contain a URL or an attempt at a URL, and is the user
|
|
# anonymous?
|
|
if ( ($text =~ m{http://|a href=}i)
|
|
and $self->get_username eq $self->DefaultUserName )
|
|
{
|
|
# Quickie spamlogging.
|
|
my $time = localtime(time);
|
|
append_file($self->SpamLogFile,
|
|
"$time $ENV{'REMOTE_ADDR'} $pagename $summary\n");
|
|
|
|
# Looks like spam.
|
|
return 1;
|
|
}
|
|
|
|
# Didn't look like spam.
|
|
return 0;
|
|
|
|
}
|
|
|
|
|
|
# Return a list of the pages linked to within a given chunk of text.
|
|
sub pagelinks {
|
|
my ($text) = shift;
|
|
|
|
# CamelCase
|
|
my (@camels) = $text =~ m/((?:[A-Z][a-z0-9]+) # One uppercase + lowercase
|
|
(?:[A-Z][a-z0-9]+)+) # + one uppercase + lower
|
|
/gsx;
|
|
|
|
# Bracketed links
|
|
my (@brackets) = $text =~ m!\[{1,2} # one or two brackets
|
|
([A-Za-z0-9.%,_'\ ]*) # everything we take
|
|
(?:\|.*)? # optional pipe
|
|
\]{1,2} # one or two brackets
|
|
!gsx;
|
|
|
|
for (@brackets) { s/ /_/g; }
|
|
|
|
return (@camels, @brackets);
|
|
}
|
|
|
|
|
|
sub add_to_page {
|
|
my $self = shift;
|
|
my ($pagename, $new_text) = @_;
|
|
|
|
# Bail out unless we got some text to add.
|
|
unless ($new_text) {
|
|
return $self->print_page($pagename) . $self->get_footer($pagename);
|
|
}
|
|
|
|
my ($summary) = $new_text =~ m/(.*?)(\n|$)/;
|
|
|
|
my $file_text = $self->get_page_text($pagename);
|
|
$file_text .= "\n\n<[" . $self->get_username() . "]> $new_text\n";
|
|
|
|
# We don't simply use append_file here, 'cause we want to
|
|
# log the change and write a diff:
|
|
return $self->write_page($pagename, $file_text, $summary);
|
|
}
|
|
|
|
sub get_page_text {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
|
|
return get_file_text($self->PagesDir . "/$pagename");
|
|
}
|
|
|
|
sub is_page {
|
|
my $self = shift;
|
|
my ($page) = @_;
|
|
|
|
if (-e $self->PagesDir . "/$page") {
|
|
return 1;
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
|
|
sub get_header {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
my ($searchlink, $result, @searchlinks);
|
|
|
|
# format a pagetitle with spaces
|
|
my $pagetitle = $pagename;
|
|
|
|
if ($pagetitle =~ m/_/) {
|
|
$pagetitle =~ tr/_/ /;
|
|
} else {
|
|
$pagetitle =~ s/([a-z])([A-Z])/$1 $2/g;
|
|
}
|
|
|
|
$result = '';
|
|
|
|
unless ($self->TestMode) {
|
|
$result = "Content-type: text/html;\n\n";
|
|
}
|
|
|
|
my $titlestring = $self->TitleString;
|
|
$result .= <<"END_HTML";
|
|
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
|
|
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
|
|
|
<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
|
|
<head>
|
|
<meta http-equiv="Content-type" content="text/html;charset=UTF-8" />
|
|
<title>${titlestring}${pagename}</title>
|
|
END_HTML
|
|
|
|
if ($self->StyleSheet ne '') {
|
|
$result .= qq{ <link rel="stylesheet" href="} . $self->StyleSheet . qq{" }
|
|
. qq{type="text/css" media="screen" />\n};
|
|
}
|
|
|
|
if ($self->FeedURL) {
|
|
$result .= qq{ <link rel="alternate" href="} . $self->FeedURL . qq{" }
|
|
. qq{type="application/atom+xml" title="RecentChanges" />\n};
|
|
}
|
|
|
|
my $scriptname = $self->ScriptName;
|
|
my $homepage = $self->HomePage;
|
|
|
|
$result .= <<"HTML";
|
|
</head>
|
|
|
|
<body>
|
|
|
|
<p class="right">
|
|
<a href="$scriptname?$homepage" class="exists">home</a> |
|
|
<a href="$scriptname?RecentChanges" class="exists">changes</a> |
|
|
<a href="$scriptname?PageIndex" class="exists" accesskey="i"><strong>i</strong>ndex</a> |
|
|
<a rel="nofollow" accesskey="e" class="exists"
|
|
href="$scriptname?action=edit&id=$pagename"><strong>e</strong>dit</a>
|
|
</p>
|
|
|
|
<h1>$pagetitle</h1>
|
|
|
|
HTML
|
|
|
|
return $result;
|
|
}
|
|
|
|
|
|
# produces a little toolbar for doing some searches, etc.
|
|
sub searchlinks {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
my (@result);
|
|
|
|
# perform a few substitutions to make wikiwords
|
|
# more palatable to search engines
|
|
my $searchtext = $pagename;
|
|
if ($searchtext =~ m/_/) {
|
|
$searchtext =~ s/_/ /g;
|
|
} else {
|
|
$searchtext =~ s/([a-z])([A-Z])/$1 $2/g;
|
|
}
|
|
|
|
# prettier text for the wikipedia link
|
|
my $wikipedia_linktext = $searchtext;
|
|
# turn camelcase into underscores for wikipedia
|
|
my $wikipedia = $searchtext;
|
|
$wikipedia =~ s/ /_/g;
|
|
|
|
$searchtext = lc $searchtext;
|
|
|
|
my $googletext = $searchtext;
|
|
$googletext =~ s/ /+/g;
|
|
|
|
my $e2text = $searchtext;
|
|
$e2text =~ s/ /%20/g;
|
|
|
|
my $tagtext = $searchtext;
|
|
$tagtext =~ s/[ _]//g;
|
|
|
|
my (@matchpages, $filename, $page);
|
|
|
|
# find p1k3 entries corresponding to pages
|
|
if ( $self->DisplayRootDir and
|
|
($pagename =~ m/(January|February|March|April|May|June|
|
|
July|August|September|October|November|December)
|
|
_([0-9]{1,2})_([0-9]{4})
|
|
/x ) ) {
|
|
|
|
my %month_num = ( January => 1, February => 2, March => 3, April => 4,
|
|
May => 5, June => 6, July => 7, August => 8,
|
|
September => 9, October => 10, November => 11,
|
|
December => 12 );
|
|
|
|
my $pp = "$3/$month_num{$1}/$2";
|
|
|
|
if (-e $self->DisplayRootDir . "/$pp") {
|
|
push @matchpages,
|
|
a($self->DisplayURL . $pp, "p1k3::$pp", 'external');
|
|
}
|
|
}
|
|
|
|
my $parameters = $self->parameters;
|
|
|
|
# Include the list of pages that link to this one.
|
|
if ( $parameters->{'action'} ne 'links' ) {
|
|
push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 15);
|
|
@matchpages = sort @matchpages;
|
|
|
|
# provide "more..." link if we got a full list.
|
|
if (@matchpages >= 15) {
|
|
push @matchpages,
|
|
a($self->ScriptName . "?action=links&id=$pagename",
|
|
'<em>more...</em>');
|
|
}
|
|
} else {
|
|
push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 0);
|
|
@matchpages = sort(@matchpages);
|
|
}
|
|
|
|
for (@matchpages) { $_ = $self->convert_wikiwords($_); }
|
|
|
|
# if any pages matched, push a blank line, a "see also:", and
|
|
# the matching page names.
|
|
if (@matchpages) {
|
|
push @result, '<strong>see also:</strong>', @matchpages, ' ';
|
|
}
|
|
|
|
push @result,
|
|
'<strong>search:</strong>',
|
|
a("http://en.wikipedia.org/wiki/Special:Search/$wikipedia",
|
|
'wikipedia'),
|
|
a("http://www.google.com/search?q=$googletext", 'google'),
|
|
' ' . a("http://scholar.google.com/scholar?q=$googletext",
|
|
'scholar'),
|
|
' ' . a("http://books.google.com/books?q=$googletext", 'books'),
|
|
' ' . a("http://images.google.com/images?q=$googletext",
|
|
'images'),
|
|
a("http://reddit.com/search?q=$googletext", 'reddit'),
|
|
a("http://del.icio.us/tag/$tagtext", 'del.icio.us'),
|
|
a("http://www.everything2.com/?node=$e2text", 'everything2');
|
|
|
|
return @result;
|
|
}
|
|
|
|
|
|
# return a list of the pages that link to a given page
|
|
# essentially a big dumb grep
|
|
sub get_linked_pages {
|
|
my $self = shift;
|
|
my ($pagename, $quantity) = @_;
|
|
|
|
# We'll search for these.
|
|
my $quoted = quotemeta($pagename);
|
|
my $with_spaces = $quoted;
|
|
$with_spaces =~ s/_/ /g;
|
|
my $spaces_on_caps = $quoted;
|
|
$spaces_on_caps =~ s/([a-z])([A-Z])/$1 $2/g;
|
|
|
|
# Useful idiom: Map a list to a hash where each value is 1.
|
|
# Stopwords:
|
|
my %stop = map { $_ => 1 } ('temp', '..', '.', '', $pagename);
|
|
|
|
opendir my $dh, $self->PagesDir;
|
|
|
|
my $filename = readdir $dh;
|
|
|
|
my @matchpages;
|
|
until ($filename eq '') {
|
|
# Bail out if we've got a desired quantity:
|
|
last if $quantity and (@matchpages >= $quantity);
|
|
|
|
$filename = readdir $dh;
|
|
|
|
# check stoplist
|
|
next if $stop{$filename};
|
|
|
|
open my $page, '<', $self->PagesDir . "/$filename";
|
|
|
|
while (<$page>) {
|
|
if ( m/$quoted|$with_spaces|$spaces_on_caps/io ) {
|
|
push @matchpages, $filename;
|
|
last;
|
|
}
|
|
}
|
|
|
|
close $page;
|
|
|
|
}
|
|
|
|
closedir DIR;
|
|
|
|
return @matchpages;
|
|
}
|
|
|
|
|
|
# This HTML really needs cleaned up.
|
|
sub get_footer {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
|
|
my $username = $self->get_username;
|
|
my $scriptname = $self->ScriptName;
|
|
|
|
my $text = <<HTML;
|
|
|
|
<form action="$scriptname" method="post">
|
|
<table class="addbox">
|
|
<tr>
|
|
<td>
|
|
<input type="hidden" name="action" value="addtext" />
|
|
<input type="hidden" name="id" value="$pagename" />
|
|
<$username><br />
|
|
HTML
|
|
|
|
$text .= a("$scriptname?action=editprefs&originalpage=$pagename",
|
|
'change name');
|
|
|
|
$text .= <<"END_HTML";
|
|
|
|
</td>
|
|
<td colspan="2">
|
|
<textarea name="text" cols="80" rows="7" style="width: 100%"></textarea>
|
|
</td>
|
|
</tr>
|
|
<tr>
|
|
<td></td>
|
|
END_HTML
|
|
|
|
# Is the user "logged in"?
|
|
if ( $username eq $self->DefaultUserName ) {
|
|
$text .= " <td>You can't post URLs until you choose a name</td>\n";
|
|
} else {
|
|
$text .= " <td></td>\n";
|
|
}
|
|
|
|
# Button.
|
|
$text .= <<END_HTML;
|
|
<td style="text-align: right;">
|
|
<input type="submit" value="add your response" />
|
|
</td>
|
|
</tr>
|
|
</table>
|
|
</form>
|
|
|
|
<p>
|
|
END_HTML
|
|
|
|
my $cookies = $self->cookies;
|
|
|
|
if (defined $cookies->{'username'}) {
|
|
#$text .= "logged in as <a href=\"$scriptname?action=editprefs&" .
|
|
# "originalpage=$page\">$cookies{'username'}</a>";
|
|
}
|
|
else {
|
|
$text .= a(
|
|
"$scriptname?action=editprefs&originalpage=$pagename",
|
|
'choose a name'
|
|
);
|
|
}
|
|
|
|
$text .= "<br />\n" . a("$scriptname?action=edit&id=$pagename",
|
|
'edit this page');
|
|
|
|
my ($diff_date, $datestamp) = $self->latest_diff($pagename);
|
|
if ($diff_date ne '') {
|
|
$text .= qq{<br />\nlast edited <a rel="nofollow" href="$scriptname?action=diff&}
|
|
. qq{id=$pagename&datestamp=$datestamp">$diff_date</a>};
|
|
}
|
|
|
|
$text .= '</p>';
|
|
|
|
$text .= "\n\n</body>\n</html>\n";
|
|
|
|
return $text;
|
|
}
|
|
|
|
|
|
# The enormous cascading if statement here does what it should,
|
|
# but needs serious disentanglement
|
|
sub print_page {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
|
|
my ($linklist, $result);
|
|
|
|
my $pagetext = get_file_text($self->PagesDir . "/$pagename");
|
|
|
|
# This needs to be specific because we might encounter "0":
|
|
if ($pagetext eq '') {
|
|
$pagetext = $self->DefaultPageText;
|
|
}
|
|
|
|
# make HTML out of our markup:
|
|
$pagetext = $self->wikify($pagetext);
|
|
|
|
# this takes care of several special pages. it also grabs links to search
|
|
# engines and backreferences to other pages.
|
|
if ($pagename eq 'RecentChanges') {
|
|
$pagetext .= $self->print_recent_changes;
|
|
}
|
|
elsif ($pagename eq 'PageIndex' ) { $pagetext .= $self->get_list_of_pages(); }
|
|
elsif ($pagename eq 'PageChangeTimes') { $pagetext .= $self->get_change_times(); }
|
|
elsif ($pagename =~ m/^([A-Za-z])$/ ) { $pagetext .= $self->get_list_of_pages("^$1.*"); }
|
|
elsif ($pagename eq 'setup' ) { $pagetext .= $self->setup(); }
|
|
elsif (! $self->ShowSearchlinks ) { $linklist = ''; }
|
|
elsif ($pagename eq $self->HomePage ) { $linklist = ''; }
|
|
else {
|
|
$linklist .= qq{<p class="searchlinks" >\n};
|
|
for my $link ($self->searchlinks($pagename)) {
|
|
$linklist .= "$link <br />\n";
|
|
}
|
|
$linklist .= "</p>\n\n";
|
|
}
|
|
|
|
$pagetext = "$linklist\n\n$pagetext" if $linklist;
|
|
|
|
return $pagetext;
|
|
}
|
|
|
|
|
|
# This is all a touch ridiculous.
|
|
sub edit_form {
|
|
my $self = shift;
|
|
my ($pagename) = @_;
|
|
|
|
my $file_text = $self->get_page_text($pagename);
|
|
$file_text ||= $self->DefaultPageText;
|
|
|
|
my $url_notice = "Feel free to post URLs.";
|
|
my $username = $self->get_username;
|
|
|
|
if ($username eq $self->DefaultUserName) {
|
|
$url_notice = "You can't add URLs <em>or edit pages containing them</em> until you choose a name.";
|
|
$username = undef;
|
|
}
|
|
|
|
my $editor = Wala::Editor->new(
|
|
page => $pagename,
|
|
message => $url_notice,
|
|
file_text => $file_text,
|
|
scriptname => $self->ScriptName,
|
|
username => $username,
|
|
);
|
|
|
|
return $editor->render();
|
|
|
|
}
|
|
|
|
|
|
sub log_page_edit {
|
|
my $self = shift;
|
|
my ($pagename, $summary, $username) = @_;
|
|
my $currenttime = time;
|
|
append_file($self->LogFile,
|
|
"$currenttime $pagename $username $summary\n");
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
# Default returns a CSS based graph with links to pages for each
|
|
# letter. Takes $pattern as a regex for filenames of pages to index.
|
|
sub get_list_of_pages {
|
|
my $self = shift;
|
|
my ($pattern) = @_;
|
|
|
|
# If no pattern was specified, just do a graph:
|
|
my $graph_only = 1 unless $pattern;
|
|
|
|
$pattern ||= ".*";
|
|
|
|
|
|
# files to ignore:
|
|
my %stop = map { $_ => 1 } ('temp', '..', '.');
|
|
|
|
my ($filename, @pages);
|
|
opendir DIR, $self->PagesDir;
|
|
while ($filename = readdir DIR) {
|
|
next if (defined $stop{$filename});
|
|
if ($filename =~ m/$pattern/) {
|
|
push @pages, $filename;
|
|
}
|
|
}
|
|
closedir DIR;
|
|
|
|
@pages = sort @pages;
|
|
|
|
my (%first_letters, $letter, $text);
|
|
|
|
foreach $filename (@pages) {
|
|
|
|
my $filename_top;
|
|
# this conditional is an optimization, but the whole loop
|
|
# is stupid and needs a rewrite
|
|
unless ($graph_only) {
|
|
$filename_top = $self->get_firstline($filename);
|
|
# clear special characters that would otherwise go unrendered
|
|
$filename_top =~ s/^[\*:#]//;
|
|
}
|
|
|
|
$filename =~ s/_/ /g;
|
|
|
|
# for first letters in index.
|
|
$letter = substr $filename, 0, 1;
|
|
unless (exists $first_letters{$letter}) {
|
|
$text .= "\n\n= [$letter] =\n\n";
|
|
}
|
|
|
|
# add 'em up.
|
|
$first_letters{$letter}++;
|
|
$text .= "* [$filename] :: $filename_top\n";
|
|
}
|
|
|
|
my (@letters) = sort (keys %first_letters);
|
|
my ($biggest_letter, $graph);
|
|
|
|
my $scriptname = $self->ScriptName;
|
|
for (@letters) {
|
|
$graph .= qq{<a style="border-top: $first_letters{$_}px solid black"}
|
|
. qq{ href="$scriptname?$_">$_</a>\n};
|
|
if ($first_letters{$_} > $biggest_letter) {
|
|
$biggest_letter = $first_letters{$_};
|
|
}
|
|
}
|
|
|
|
my $pagecount = @pages;
|
|
|
|
$biggest_letter += 10;
|
|
|
|
# If $graph_only is set, we won't return the whole list.
|
|
my ($result) = qq{<p style="margin-top: ${biggest_letter}px; text-align:}
|
|
. qq{ center;">$graph<br />\n$pagecount pages</p>\n\n};
|
|
|
|
unless ($graph_only) {
|
|
$result .= qq{<div style="font-size: .7em;">\n}
|
|
. $self->wikify($text) . "\n</div>";
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
|
|
# Return the first (real) line of a file.
|
|
sub get_firstline {
|
|
my $self = shift;
|
|
my ($filename) = @_;
|
|
my ($filename_top);
|
|
|
|
open (my $fh, '<', $self->PagesDir . "/$filename") or return '';
|
|
|
|
while ($filename_top = <$fh>) {
|
|
# make sure it has real content
|
|
if (length($filename_top) > 1 ) {
|
|
chomp($filename_top);
|
|
last;
|
|
}
|
|
}
|
|
|
|
close $fh;
|
|
|
|
return $filename_top;
|
|
}
|
|
|
|
|
|
# little wrapper to
|
|
# just return an mtime for a file.
|
|
sub get_mtime
|
|
{
|
|
my (@filenames) = @_;
|
|
|
|
my @mtimes;
|
|
for my $filename (@filenames) {
|
|
#my( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
|
|
# $atime, $mtime, $ctime, $blksize, $blocks )
|
|
# = stat( $filename );
|
|
|
|
push @mtimes, (stat $filename)[9];
|
|
}
|
|
|
|
# return a list if we've got more than one, a scalar
|
|
# otherwise. is this evil? or even necessary?
|
|
if (@mtimes > 1) {
|
|
return @mtimes;
|
|
} else {
|
|
return $mtimes[0];
|
|
}
|
|
}
|
|
|
|
|
|
# List all files with their mtimes.
|
|
sub get_change_times
|
|
{
|
|
my $self = shift;
|
|
my ($pattern) = @_;
|
|
$pattern ||= ".*";
|
|
my ($text, %mtimes);
|
|
|
|
my (@months) = qw(January February March April May June
|
|
July August September October November
|
|
December);
|
|
|
|
# files to ignore:
|
|
my %stop = map { $_ => 1 } ('temp', '..', '.');
|
|
|
|
opendir DIR, $self->PagesDir;
|
|
while (my $filename = readdir DIR) {
|
|
next if (exists $stop{$filename});
|
|
if ($filename =~ m/$pattern/) {
|
|
$mtimes{$filename} = get_mtime($self->PagesDir . "/$filename");
|
|
}
|
|
}
|
|
closedir DIR;
|
|
|
|
my @pages = keys %mtimes;
|
|
@pages = sort { $mtimes{$a} <=> $mtimes{$b}; } @pages;
|
|
|
|
my $last_modtime;
|
|
foreach my $filename (@pages)
|
|
{
|
|
my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
|
|
localtime $mtimes{$filename};
|
|
|
|
my $modtime = "$months[$mon] $mday " . ($year + 1900);
|
|
|
|
if ($last_modtime eq $modtime) {
|
|
$text .= " [$filename] ";
|
|
} else {
|
|
$text .= "\n* '''[$modtime]''' :: [$filename] ";
|
|
}
|
|
|
|
$last_modtime = $modtime;
|
|
}
|
|
|
|
$text = "\n" . $self->wikify($text) . "\n";
|
|
|
|
return $text;
|
|
}
|
|
|
|
|
|
######################
|
|
# Recent Changes #
|
|
######################
|
|
|
|
|
|
sub print_recent_changes {
|
|
my $self = shift;
|
|
my ($max_lines) = @_;
|
|
$max_lines ||= $self->RecentChangesMaxLines;
|
|
|
|
my @lines = $self->recent_changes($max_lines);
|
|
|
|
my ($result, $last_date);
|
|
|
|
foreach my $line (@lines) {
|
|
chop $line;
|
|
my ($addline, $datestamp) = $self->format_changeline($line);
|
|
|
|
if ($datestamp ne $last_date) {
|
|
unless ($last_date eq '') {
|
|
$result .= "\n\n";
|
|
}
|
|
$result .= "''$datestamp''\n\n";
|
|
$last_date = $datestamp;
|
|
}
|
|
|
|
$result .= $addline;
|
|
}
|
|
|
|
# format_changeline returns lines in wiki markup:
|
|
return $self->wikify($result);
|
|
}
|
|
|
|
# Return recent changes lines from log file.
|
|
# Should be cleaned up. The logic is a bit tortured.
|
|
sub recent_changes {
|
|
my $self = shift;
|
|
my ($max_lines) = @_;
|
|
|
|
# Going to use this as an array index.
|
|
$max_lines--;
|
|
|
|
# Open the logfile or return a null result.
|
|
open (my $logfile, '<', $self->LogFile) or return '';
|
|
my @lines = <$logfile>;
|
|
close $logfile;
|
|
|
|
# only return up to the end of @lines
|
|
if (@lines < $max_lines) {
|
|
$max_lines = (@lines - 1);
|
|
}
|
|
|
|
@lines = reverse(@lines); # Missy Elliot.
|
|
|
|
return @lines[0..$max_lines];
|
|
}
|
|
|
|
|
|
# Format a line from the logfile.
|
|
# This whole thing should be rewritten.
|
|
sub format_changeline
|
|
{
|
|
my $self = shift;
|
|
my ($line) = @_;
|
|
|
|
my @months = qw( January February March April May June
|
|
July August September October November December );
|
|
|
|
my ($timestamp, $pagename, $author, $description)
|
|
= $line =~ m/(\d+) (\S+) (\w+) (.*)$/;
|
|
|
|
my @t = localtime($timestamp);
|
|
my $year = $t[5] + 1900;
|
|
|
|
my $datestamp = $months[$t[4]] . " $t[3], $year";
|
|
|
|
my ($ampm);
|
|
my $hour = $t[2];
|
|
if ($hour == 0) { $ampm = 'am'; $hour = 12; }
|
|
elsif ($hour < 12) { $ampm = 'am'; }
|
|
elsif ($hour == 12) { $ampm = 'pm'; }
|
|
else { $ampm = 'pm'; $hour -= 12; }
|
|
|
|
my $min = $t[1];
|
|
if (length($min) == 1) { $min = '0' . $min; }
|
|
my $thetime = "$hour:$min $ampm";
|
|
|
|
my $result = qq{* [$pagename] $description ''$author, $thetime }
|
|
. $self->TimeZone
|
|
. qq{''\n};
|
|
|
|
return $result, $datestamp;
|
|
}
|
|
|
|
|
|
###############################
|
|
# Preferences and Cookies #
|
|
###############################
|
|
|
|
|
|
# So far this just handles the username.
|
|
sub get_preferences_form {
|
|
my $self = shift;
|
|
my ($originalpage) = @_;
|
|
|
|
my $scriptname = $self->ScriptName;
|
|
my $username = $self->get_username;
|
|
|
|
my $text = <<"END_HTML";
|
|
<form action="$scriptname" method="post">
|
|
<table>
|
|
<tr>
|
|
<td>
|
|
<input type="hidden" name="action" value="setprefs" />
|
|
<input type="hidden" name="id" value="$originalpage" />
|
|
Your login name:
|
|
</td>
|
|
<td>
|
|
<input type="text" name="username" value="$username"
|
|
size="20" />
|
|
</td>
|
|
</tr>
|
|
<tr>
|
|
<td></td>
|
|
<td>(Letters and/or numbers only, no spaces)</td>
|
|
</tr>
|
|
<tr>
|
|
<td><input type="submit" value="Save" /></td>
|
|
</tr>
|
|
</table>
|
|
</form>
|
|
END_HTML
|
|
|
|
return $text;
|
|
}
|
|
|
|
|
|
|
|
|
|
# I think we need to address $cookies
|
|
# which is probably persisting across
|
|
# sessions due to mod_perl.
|
|
sub parse_cookies {
|
|
my $self = shift;
|
|
my ($cookie_string) = @_;
|
|
|
|
# see if this works
|
|
my %cookies;
|
|
my @values = split /&/, $cookie_string;
|
|
foreach my $query (@values) {
|
|
my ($name, $value) = split(/=/, $query);
|
|
$value =~ tr/+/ /;
|
|
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
|
$cookies{$name} = $value;
|
|
}
|
|
|
|
$self->cookies(\%cookies);
|
|
}
|
|
|
|
|
|
|
|
# formerly write_cookies_to_browser
|
|
sub set_cookies
|
|
{
|
|
my $self = shift;
|
|
my ($username, $newpage) = @_;
|
|
my $expiration_time = mygmtime(time + 86400 * $self->CookieSurvivalDays);
|
|
if( $username =~ /^[A-Za-z0-9]+$/ ) {
|
|
print "Set-Cookie: username=$username; expires=$expiration_time\n";
|
|
}
|
|
$self->location($newpage);
|
|
}
|
|
|
|
|
|
|
|
|
|
#############
|
|
# Setup #
|
|
#############
|
|
|
|
|
|
sub setup {
|
|
my $self = shift;
|
|
|
|
my $pagesdir = $self->PagesDir;
|
|
my $homepage = $self->HomePage;
|
|
|
|
my $result = '<p>';
|
|
|
|
if (! -d $self->RootDir) {
|
|
if ( mkdir $self->RootDir, 0777 ) {
|
|
$result .= 'Made root directory.<br />';
|
|
} else {
|
|
return;
|
|
}
|
|
}
|
|
|
|
if (! -d $pagesdir)
|
|
{
|
|
if ( mkdir $pagesdir, 0777 ) {
|
|
$result .= 'Made pages directory.<br />';
|
|
}
|
|
|
|
if ( mkdir( $self->DiffDir, 0777 ) ) {
|
|
$result .= 'Made diffs directory.<br />';
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$result .= 'Root directory exists.<br />';
|
|
}
|
|
|
|
if( ! -d $self->CacheDir )
|
|
{
|
|
mkdir( $self->CacheDir, 0777 );
|
|
$result .= 'Made cache directory.<br />';
|
|
}
|
|
else
|
|
{
|
|
$result .= 'Cache directory exists.<br />';
|
|
}
|
|
|
|
if( ! -e "$pagesdir/" . $self->HomePage )
|
|
{
|
|
write_file("$pagesdir/$homepage",
|
|
"Welcome to the Wala.\n\n"
|
|
. "See TextFormattingRules\n");
|
|
$result .= "Created $homepage.<br />";
|
|
}
|
|
else
|
|
{
|
|
$result .= 'HomePage exists.<br />';
|
|
}
|
|
|
|
if( ! -e "$pagesdir/TextFormattingRules" )
|
|
{
|
|
my $markup = <<"MARKUP";
|
|
Wala has the following '''text formatting rules''':
|
|
* Start a line with * to create a ''bulleted list''.
|
|
# Start a line with # to create a ''numbered list''.
|
|
:Start a line with a : to indent it.
|
|
Start a line with a space to display it like source code.
|
|
Start a line with a | to create a table:
|
|
|This is|a table|
|
|
|specified with|formatting rules.|
|
|
SmashWordsTogetherLikeSo to create a link to a new page, or use brackets around a [word]. Click on the link to create the page.
|
|
|
|
For links, just type the URL:
|
|
|
|
http://walawiki.org/
|
|
|
|
Alternatively, surround the URL with brackets and put a description after it, separated by a space:
|
|
[http://walawiki.org WalaWiki]
|
|
To include an image, just type the URL of the image.
|
|
MARKUP
|
|
write_file("$pagesdir/TextFormattingRules", $markup);
|
|
$result .= "Created TextFormattingRules.<br />";
|
|
}
|
|
else
|
|
{
|
|
$result .= "TextFormattingRules exists.<br />";
|
|
}
|
|
|
|
$result .= "</p>\n\n";
|
|
return( $result );
|
|
}
|
|
|
|
|
|
|
|
|
|
sub parse_parameters
|
|
{
|
|
my $self = shift;
|
|
my ($query_string) = shift;
|
|
|
|
my %parameters;
|
|
|
|
foreach my $query ( split( /&/, $query_string ) ) {
|
|
my ($name, $value) = split(/=/, $query);
|
|
$value =~ tr/+/ /;
|
|
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
|
$parameters{$name} = $value;
|
|
}
|
|
|
|
$self->parameters(\%parameters);
|
|
|
|
my $action = $parameters{'action'};
|
|
|
|
# Cut off access to ../ etc.
|
|
if (substr($parameters{'id'}, 0, 1) eq '.') {
|
|
$parameters{'id'} = $self->HomePage;
|
|
}
|
|
|
|
$_[0] = $parameters{'id'};
|
|
|
|
if ( $action eq 'edit' ) {
|
|
return $self->edit_form($parameters{'id'});
|
|
}
|
|
elsif ( $action eq 'post' ) {
|
|
my $w_result = $self->write_page($parameters{'id'},
|
|
$parameters{'filetext'},
|
|
$parameters{'summary'},
|
|
$parameters{'timestamp'});
|
|
|
|
if ($w_result) {
|
|
# If write_page returned anything, pass that along for display.
|
|
return $w_result;
|
|
} else {
|
|
# Otherwise redirect the browser to the current version of the page.
|
|
$self->location($parameters{'id'});
|
|
}
|
|
}
|
|
elsif ( $action eq 'addtext' ) {
|
|
$self->add_to_page($parameters{'id'}, $parameters{'text'});
|
|
$self->location($parameters{'id'}); # redirect to current version of page
|
|
}
|
|
elsif ( $action eq 'diff' ) {
|
|
$_[0] .= ' Diff';
|
|
return $self->get_diff($parameters{'id'}, $parameters{'datestamp'})
|
|
. "<hr />\n"
|
|
. $self->print_page($parameters{'id'});
|
|
}
|
|
elsif ( $action eq 'setprefs' ) {
|
|
$self->set_cookies($parameters{'username'}, $parameters{'id'});
|
|
}
|
|
elsif ( $action eq 'editprefs' ) {
|
|
$_[0] = 'Preferences';
|
|
return $self->get_preferences_form($parameters{'originalpage'});
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
############
|
|
# Diff #
|
|
############
|
|
|
|
|
|
sub get_diff
|
|
{
|
|
my $self = shift;
|
|
my ($pagename, $datestamp) = @_;
|
|
|
|
my $text = get_file_text($self->DiffDir . "/$pagename/$datestamp");
|
|
|
|
my (@lines) = split /\n/, $text;
|
|
|
|
my $added_text = "<strong>Added:</strong><br />\n" .
|
|
qq{<div style="background-color: #AAFFAA">\n};
|
|
|
|
my $removed_text = "<strong>Removed:</strong><br />\n" .
|
|
qq{<div style="background-color: #FFffAA">\n};
|
|
|
|
$text = '';
|
|
|
|
# some regexes here might be more legible.
|
|
foreach my $line (@lines) {
|
|
#if( substr( $line, 0, 1 ) eq '<' || substr( $line, 0, 1 ) eq '>' )
|
|
if ($line =~ m/^[<>]/)
|
|
{
|
|
$text .= substr($line, 1) . "<br />\n";
|
|
}
|
|
elsif (substr( $line, 0, 3) eq '---' )
|
|
{
|
|
$text .= "</div>\n$removed_text";
|
|
}
|
|
elsif (index($line, 'a') >= 0 && substr($line, 0, 1) ne '\\' )
|
|
{
|
|
$text .= "</div>\n$removed_text";
|
|
}
|
|
elsif (index($line, 'c') >= 0 && substr($line, 0, 1) ne '\\' )
|
|
{
|
|
$text .= "</div>\n$added_text";
|
|
}
|
|
}
|
|
|
|
return $text . "</div>\n";
|
|
}
|
|
|
|
|
|
|
|
|
|
# Now returns a summary of the edit.
|
|
# to-fix: locking on files?
|
|
# any weird vulnerabilities?
|
|
sub write_diff
|
|
{
|
|
my $self = shift;
|
|
my ($pagename, $new_text) = @_;
|
|
|
|
my $currtime = time;
|
|
my $tempfile = $self->DiffDir . "/$pagename.$currtime.temp";
|
|
my $pagefile = $self->PagesDir . "/$pagename";
|
|
|
|
my $diffdir = $self->DiffDir . "/$pagename";
|
|
|
|
my $from_scratch;
|
|
unless (-d $diffdir) {
|
|
mkdir $diffdir, 0777;
|
|
$from_scratch = $new_text;
|
|
}
|
|
|
|
write_file($tempfile, $new_text);
|
|
my $the_diff = `diff '$tempfile' '$pagefile'`;
|
|
unlink $tempfile; # get rid of tempfile
|
|
|
|
my $change_count;
|
|
$change_count++ while $the_diff =~ /[0-9,]+[acd][0-9,]+/sg;
|
|
|
|
# Get a list of wikiwords from the diff and new text, for "Related: "
|
|
my (@link_list) = pagelinks($the_diff . $from_scratch);
|
|
|
|
my $summary;
|
|
if ($change_count == 1) {
|
|
$summary = "One change.";
|
|
} elsif ($change_count == 0) {
|
|
$summary = "New page or unchanged.";
|
|
} else {
|
|
$summary = "$change_count changes.";
|
|
}
|
|
|
|
# Make sure the links in our related list are unique:
|
|
my %seen = ();
|
|
@link_list = grep { ! $seen{$_} ++ } @link_list;
|
|
|
|
if (@link_list) { $summary .= " Related: @link_list"; }
|
|
|
|
write_file($diffdir . "/$currtime", $the_diff);
|
|
|
|
return $summary;
|
|
}
|
|
|
|
|
|
sub latest_diff {
|
|
my $self = shift;
|
|
my ($pagename) = shift;
|
|
|
|
my @months = qw(January Febuary March April May June
|
|
July August September October November
|
|
December);
|
|
|
|
opendir (DIR, $self->DiffDir . "/$pagename")
|
|
or return '';
|
|
|
|
my @filenames;
|
|
while (my $filename = readdir DIR) {
|
|
if ($filename =~ /^\d+$/) {
|
|
push @filenames, $filename;
|
|
}
|
|
}
|
|
|
|
closedir DIR;
|
|
|
|
@filenames = reverse sort @filenames;
|
|
my @t = localtime($filenames[0]);
|
|
my $datestamp = $filenames[0];
|
|
|
|
return $months[$t[4]] . ' ' . $t[3] . ', ' . ($t[5] + 1900),
|
|
$datestamp;
|
|
}
|
|
|
|
|
|
|
|
|
|
#################
|
|
# Utilities #
|
|
#################
|
|
|
|
|
|
sub get_username {
|
|
my $self = shift;
|
|
|
|
my $cookies = $self->cookies;
|
|
|
|
if ($cookies->{'username'}) {
|
|
return $cookies->{'username'};
|
|
} else {
|
|
return $self->DefaultUserName;
|
|
}
|
|
}
|
|
|
|
sub mygmtime {
|
|
my ($etime) = @_;
|
|
my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
|
my @days = qw(Sun Mon Tue Wed Thu Fri Sat);
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($etime);
|
|
my $timestr = sprintf( "%3s, %02d-%3s-%4d %02d:%02d:%02d GMT",
|
|
$days[$wday], $mday, $months[$mon], $year+1900, $hour, $min, $sec);
|
|
|
|
return $timestr;
|
|
}
|
|
|
|
# Return an ISO 8601 date string for the given epoch.
|
|
sub iso_date {
|
|
my ($time) = @_;
|
|
return strftime("%Y-%m-%dT%H:%M:%S%z", localtime($time));
|
|
}
|
|
|
|
# These next three are pretty much as advertised.
|
|
sub get_file_text {
|
|
my ($filename) = @_;
|
|
|
|
open (my $fh, $filename)
|
|
or return '';
|
|
|
|
local $/ = undef;
|
|
my $filetext = <$fh>;
|
|
close $fh;
|
|
|
|
return $filetext;
|
|
}
|
|
|
|
sub write_file {
|
|
my ($filename, $text) = @_;
|
|
|
|
open (my $fh, '>', $filename) or return 0;
|
|
flock($fh, LOCK_EX);
|
|
print $fh $text;
|
|
close $fh;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# This may not be that useful.
|
|
sub append_file {
|
|
my ($filename, $text) = @_;
|
|
|
|
open (my $fh, '>>', $filename) or return 0;
|
|
flock($fh, LOCK_EX);
|
|
print $fh $text;
|
|
close $fh;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# Redirect to a given page and exit.
|
|
sub location {
|
|
my $self = shift;
|
|
my ($newpage) = @_;
|
|
print "Location: " . $self->ScriptName . "?$newpage\n\n";
|
|
exit 0;
|
|
}
|
|
|
|
1;
|