#!/usr/bin/perl
#use FindBin;
#use lib "$FindBin::Bin";
use File::Basename;
use lib dirname(__FILE__); # TODO: portable? maybe use $0?
use locale;
use POSIX qw(locale_h strftime);
use CGI; # qw(:cgi);
use Format qw(:all);
use Link qw(:all);
use Store qw(:all);
use User qw(:all);
use Charset;
use constant DAY => scalar 60*60*24;
################################################################################
# I n i t i a l i z a t i o n #
################################################################################
# 'my' vars for use within chiq.pl, 'our' vars for use in included scripts
our $script_name = CGI::script_name();
our $script_path = substr($script_name, 0, rindex($script_name, '/'));
our $group = pop_cgi_param('group');
($group !~ /\W/) or die("Illegal group: $group");;
our $user_id;
our $user_name;
# read config vars
our $config = ($group || 'chiq') . '.cf';
my $ret = do $config;
unless (defined $ret) {
$@ = $@ ? "Couldn't parse $config: $@" : "Couldn't read $config: $!";
die("Error loading configuration: $@");
}
my %standard_substitutions;
my $recent_changes_legend;
my $old_changes_legend;
configure();
my $recent_changes = $change_log . '.txt'; # reverse list of recent changes
$user_id ||= CGI::cookie($cookie_name);
my $user_cookie;
$user_id ||= new_user();
$user_name ||= user_name($user_id);
################################################################################
# C o n f i g u r a t i o n #
################################################################################
### configure() # Use config variables to set settings. ########################
sub configure {
# configure locale:
setlocale(LC_ALL, $locale);
# or log_event("Bad locale: $locale");
$charset ||= Charset::locale2charset($locale);
# configure Format:
register_emoticons($emoticons_dir, $emoticons_ext, \%emoticons)
if (scalar keys(%emoticons));
register_emoticons($graphics_dir . '/e-', '.gif', {'|#|' => 'sep'});
register_bullets($bullets_dir, $bullets_ext, \@graphical_bullets)
if (scalar @graphical_bullets);
# configure Link:
$group_url = '';
$group_end_url = '';
$group_input = '';
if ($group) {
$group_url = "group=$group&title=";
$group_end_url = "&group=$group";
$group_input = qq();
implicit_search_form($script_name, 'search', $group_input);
}
implicit_link_url("$script_name?$group_url", '', $empty_tooltip, in_array('new', \@disabled_actions));
$implicit_external_links{'?'} = "$script_name?search=\$1$group_end_url";
# TODO: also register other chiq groups by globing for .cf and adding them to %implicit_external_links
# set global page content substitutions:
%standard_substitutions = (
'script_name' => $script_name,
'referer' => referring_title(),
'group_url' => $group_url,
'group_end_url' => $group_end_url,
'group_input' => $group_input,
'logo_title' => $logo_title,
'graphics_dir' => $graphics_dir,
'emoticons_dir' => $emoticons_dir,
'title_actions' => layout($title_actions),
'topbar' => layout($topbar),
'bottombar' => layout($bottombar),
map {$_ . '_display' => 'none'} @disabled_actions, # hide controls for disabled actions
);
$recent_changes_legend = qq(
);
# hidden="X" means X is the dafult value, which the user can override
# locked="true" means the user can't override this option
$old_changes_legend = qq(
);
}
sub pop_cgi_param {
my $param = shift;
my $value = CGI::param($param);
CGI::Delete($param);
return $value;
}
sub referring_title {
my $url = CGI::referer();
my $title = ($url =~ /\?.*(?:title|keywords)=([^&;]+)/)
? $1
: substr($url, index($url, '?')+1);
unescape_url($title);
$title = $default_title if (!$title or $title =~ /[^\w']/);
return $title;
}
################################################################################
# M a i n #
################################################################################
main() if (!CGI::param('test'));
sub main {
my $page = dispatch_request();
my $header = CGI::header(-cookie => $user_cookie, -charset => $charset, -expires => $expires);
print $header, $page;
}
sub dispatch_request {
( (scalar(CGI::param()) == 0)
&& browse_page($default_title) ) ||
( CGI::param('keywords')
&& browse_page(CGI::param('keywords')) ) ||
( CGI::param('title')
&& browse_page(pop_cgi_param('title')) ) ||
( CGI::param('new')
&& news_page(CGI::param('new'), CGI::param('till')) ) ||
( CGI::param('oldnew')
&& old_news_page(CGI::param('oldnew'), CGI::param('till')) ) ||
( CGI::param('err')
&& err_page(CGI::param('err')) ) ||
( CGI::param('edit')
&& edit_page(CGI::param('edit')) ) ||
( CGI::param('search')
&& search_page(CGI::param('search')) ) ||
( CGI::param('go')
&& go_to_page(CGI::param('go')) ) ||
( CGI::param('add')
&& add_to_page(CGI::param('add'), CGI::param('content')) ) ||
( CGI::param('teaser')
&& teaser_page(CGI::param('teaser'), CGI::param('text'), CGI::param('original_author')) ) ||
( CGI::param('save')
&& save_page(CGI::param('save'), CGI::param('content')) ) ||
( CGI::param('delete')
&& delete_page(CGI::param('delete')) ) ||
( CGI::param('rename')
&& rename_page(CGI::param('rename'), CGI::param('to')) ) ||
( CGI::param('stats')
&& stats_page(CGI::param('stats')) ) ||
( CGI::param('like')
&& print CGI::header('text/html','204 No response') and exit ) ||
err("Unsupported request parameters in group $group: " . CGI::query_string());
}
################################################################################
# E r r o r H a n d l i n g #
################################################################################
### err($message) # Report an error and exit. ##################################
sub err {
my ($msg) = @_;
log_error($msg);
print fill_in($error_page, {msg => $msg});
exit;
}
### log_error($message) # Add a message to the error log. ######################
sub log_error {
if (open(LOG, ">> $error_log")) {
my (undef, $filename, $line, $subroutine) = caller(2);
my $time = time_now();
print LOG "$time - $_[0]\n";
print LOG "\t", "at $filename:$line inside $subroutine\n";
print LOG "\t", "by user $user_id in group $group\n";
print LOG "\t", "with parameters ", join('&' ,map {$_ . '=' . CGI::param($_)} CGI::param() );
# print LOG "\n\t", "complete request: ", CGI::url(-path => 1, -query => 1);
print LOG "\n";
close LOG;
}
}
### log_event($message) # Add a message to the event log. ######################
sub log_event {
if (open(LOG, ">> $event_log")) {
print LOG time_now(), " - $_[0]\n";
print LOG "\t", "by user $user_id in group $group\n";
close LOG;
}
return 1;
}
################################################################################
# U s e r R e q u e s t s #
################################################################################
### $html = browse_page($title) # Return a page as HTML. #######################
sub browse_page {
my ($title) = @_;
fix_title($title);
log_visit($title);
return news_page()
if (lc($title) eq lc($news_page_title));
return teaser_page()
if (lc($title) eq lc($teasers_page_title));
show_page($title, 'view',
{'body' => layout_page($title, $right_to_left, $single_browse_window),
random_teaser()},
is_static($title)
);
}
### $html = err_page($title) # Return a nice error page. #######################
sub err_page {
my ($title) = @_;
my %error_values = CGI::Vars;
my $msg = join "\n", map {"***$_:\n" . $error_values{$_}} keys(%error_values);
log_error($msg);
show_page($title, 'err');
}
### $html = edit_page($title) # Return a form for editing the page contents. ###
sub edit_page {
my ($title) = @_;
fix_title($title);
check_permissions($title, 'edit');
show_page($title, 'edit', {'contents' => get_page_content($title)});
}
### add_to_page($title, $text) # Add new section to a page. ####################
sub add_to_page {
my ($title, $text) = @_;
fix_title($title);
check_permissions($title, 'add', $text);
if ($text ne '') {
my $author = author_name();
my $action = page_exists($title) ? 'add' : 'new';
my $time = strftime $time_format, localtime;
my $heading = fill_in($section_heading, {'author' => $author, 'time' => $time});
append_page_contents($title, "\n\n{$heading\n$text\n}\n")
or err("Error appending to page $title: $!");
log_change($title, $author, $action);
}
show_page($title . '#bottom', 'ack');
}
### teaser_page($source, $text) # Add new section to the teasers page. #########
sub teaser_page {
err("Random teasers are disabled")
unless ($teasers_page_title && !is_static($teasers_page_title));
my ($source, $text, $original_author) = @_;
my $teaser = $text;
if ($text ne '' and $source ne '') {
$source = "$original_author $teaser_attribution $source";
$source =~ s/^\s+|\s+$//g;
$teaser .= "\r\n($source)";
$text .= "\r\n$source";
}
show_page($teasers_page_title, 'view',
{'body' => layout_page($teasers_page_title, $right_to_left, $single_browse_window),
'bottom_extra' => teaser_preview($teaser),
'content' => $text,
random_teaser()},
0 # not static
);
}
### teaser_preview($text) # Return the teaser preview HTML segment. ############
sub teaser_preview {
my $teaser_preview = shift || $empty_teaser_preview;
my $segment = read_skin('teaser_preview');
fill_in( $segment,
{%standard_substitutions,
'empty_teaser_preview' => $empty_teaser_preview,
'max_teaser_length' => $max_teaser_length,
'teaser_preview' => $teaser_preview} );
}
### save_page($title, $content) ####################################
### Save new page contents (after edit).
sub save_page {
my ($title, $content) = @_;
fix_title($title);
check_permissions($title, 'save', $content);
my $author = author_name();
my $action = page_exists($title) ? 'edit' : 'new';
backup_page_contents($title, time_now(), time_now(time()-$backup_expiry*DAY))
if ($backup_on_edit);
save_page_contents($title, $content)
or err("Error saving to page $title: $!");
log_change($title, $author, $action);
show_page($title, 'ack');
}
### rename_page($title, $new_title, $content) ##################################
### Rename and update a page and all references to it.
sub rename_page {
my ($old_title, $new_title, $content) = @_;
check_permissions($old_title, 'rename', $new_title);
if (page_exists($new_title)) {
err("Cannot rename $old_title to $new_title - page already exists.");
}
# rename the page
$content ||= page_contents($old_title);
backup_page_contents($old_title, time_now());
save_page_contents($new_title, $content)
or err("Error saving to page $new_title: $!");
log_change($new_title, author_name(), 'rename', $old_title);
# change all references
my $s; # page contents as string
my $n; # number of replacements made
foreach $page (all_titles()) {
$s = page_contents($page) or err("Error reading contents of page $page: $!");
$n = $s =~ s/\b$old_title\b/$new_title/eg;
save_page_contents($page, $s) or err("Error saving to page $page: $!") if ($n > 0);
}
show_page($new_title, 'ack');
}
### delete_page($title) # Delete a page. #######################################
sub delete_page {
my ($title) = @_;
fix_title($title);
check_permissions($title, 'delete');
my $author = author_name();
backup_page_contents($title, time_now());
log_change($title, $author, 'delete');
show_page($title, 'ack');
}
### $html = search_page(@words) # Find titles and pages containing @words. #####
sub search_page {
my @words = split /\s/, $_[0];
my ($titles, $pages) = find_pages(@words);
my $html = read_skin('search');
fill_in( $html,
{%standard_substitutions,
'words' => $_[0],
'search_box' => link_implicitly("[?$_[0]]"),
'titles_num' => scalar(@$titles),
'contents_num' => scalar(@$pages),
'titles' => link_implicitly( join(" \n", @$titles) ),
'contents' => link_implicitly( join(" \n", @$pages) )
} );
}
### $html = go_to_page(@words) # Go to first page containing @words. ###########
sub go_to_page {
my @words = split /\s/, $_[0];
my ($titles, $pages) = find_pages(@words);
return show_page($$titles[0], 'ack') if (scalar(@$titles));
return show_page($$pages[0], 'ack') if (scalar(@$pages));
return search_page(@_);
}
### $html = stats_page($re) # Calc stats of pages w/ titles matching $re. ######
sub stats_page {
my $re = $_[0];
my ($titles, $creation, $last_edit, $versions, $sections, $words, $chars) = analyze_pages($re);
# Prepare xml
my @titles = map {"
$_"} @$titles;
my @creation = map {"$_"} @$creation;
my @last_edit = map {"$_"} @$last_edit;
my @versions = map {"$_"} @$versions;
my @sections = map {"$_"} @$sections;
my @words = map {"$_"} @$words;
my @chars = map {"$_"} @$chars;
my $xml = qq(\n);
for (0..$#titles) {
$xml .= "\n\t" .
"\n\t\t$titles[$_]\n\t\t$creation[$_]\n\t\t$last_edit[$_]" .
"\n\t\t$versions[$_]\n\t\t$sections[$_]\n\t\t$words[$_]" .
"\n\t\t$chars[$_]" .
"\n\t";
}
$xml .= "\n";
# Insert flesh into skin
my $html = read_skin('stats');
fill_in( $html,
{%standard_substitutions,
're' => $re,
'titles_num' => scalar @titles,
'versions_num' => eval {$_ = join('+', @versions); s/[^\d\+]//g; eval},
'sections_num' => eval {$_ = join('+', @sections); s/[^\d\+]//g; eval},
'words_num' => eval {$_ = join('+', @words); s/[^\d\+]//g; eval},
'chars_num' => eval {$_ = join('+', @chars); s/[^\d\+]//g; eval},
'page_stats' => $xml
} );
}
### $html = news_page($num) # Show new and updated pages since $num. ###########
sub news_page {
my ($news_span) = @_;
my $time_span = (!defined($news_span) or $news_span == 0) ? CGI::cookie('fromDays') : $news_span;
log_visit("new=$time_span");
# calculate time span
my ($from, $to) = split(/[-\s]+/, $time_span);
$from = 3 if ($from == 0 && $to == 0); # TODO: move 3 to chiq.cf
my $now = time();
my $first_time = $from < 10000000000000 ? time_now($now - $from*DAY) : $from;
my $last_time = $to < 10000000000000 ? time_now($now - $to*DAY) : $to;
if ($first_time > $last_time) {
($first_time, $last_time) = ($last_time, $first_time);
($from, $to) = ($to, $from);
}
# find the recent changes
my @changes; # all changes since $first_time
my %titles; # changed pages and their serial#
my %x_titles;# titles changed after last_time are exluded
my %authors; # active authors and their serial#
my $change; # current change record
my ($time, $title, $author); # change data
open(RLOG, $recent_changes) or
log_event("Can't open recent changes log $recent_changes for reading: $!");
while ($change = ) {
chomp($change);
(undef, $time, undef, $title, $author) = split(/\t/, $change);
last if ($time < $first_time);
$x_titles{$title} = 1, next if ($time > $last_time);
next if (exists $x_titles{$title});
push(@changes, $change);
$titles{$title} = scalar keys %titles if (!exists($titles{$title}));
$authors{$author} = scalar keys %authors if (!exists($authors{$author}));
}
close RLOG;
# format the changes
my $changes_xml =
'' .
join('', map {change2xml(\%titles, \%authors)} @changes) .
"\n";
my $visits_xml =
'' .
join( '', map(visit2xml(\%titles), get_user_visits($user_id, $group)) ) .
"\n";
my $titles_xml =
'' .
join('', map {title2xml('P', $_, $titles{$_})} keys(%titles)) .
"\n";
my $authors_xml =
"" .
join('', map {title2xml('U', $_, $authors{$_})} keys(%authors)) .
"\n";
my $xml_data = $visits_xml . $titles_xml . $authors_xml . $changes_xml;
# put all this flesh in the skin
my $html = read_skin('recent');
my $xml =
'' .
qq(\n\n) .
$recent_changes_legend . $xml_data .
"";
$xml =~ s/&/&/g if ($group);
my $xslPre = read_whole_file($recent_pre);
my $xslPost = read_whole_file($recent_post);
fill_in( $html,
{%standard_substitutions,
'n' => $from,
'news_span' => (($to=='')? '' : $to . '-') . $from,
'news_page_title' => $news_page_title,
'title' => $news_page_title,
'data' => $xml,
'xslPre' => $xslPre,
'xslPost' => $xslPost} );
}
### $html = old_news_page($num) # Old version of news_page. ###########
sub old_news_page {
# news time span
my ($num, $till) = @_;
my $first_time = $num < 10000000000000 ? time_now(time() - $num*DAY) : $num;
my $last_time = $till < 10000000000000 ? time_now(time() - $till*DAY) : $till;
log_visit("oldnew=$num-$till");
# find the recent changes
my @changes; # all changes since $first_time
my %x_titles;# titles changed after last_time are exluded
my $change; # current change record
my ($time, $title); # change data
open(RLOG, $recent_changes) or
err("Can't open recent changes log $recent_changes for reading: $!");
while ($change = ) {
chomp($change);
(undef, $time, undef, $title) = split(/\t/, $change);
last if ($time < $first_time);
$x_titles{$title} = 1, next if ($time > $last_time);
next if (exists $x_titles{$title});
push(@changes, $change);
}
close RLOG;
# format the changes
my $changes_xml = join('', map {old_change2xml()} @changes);
$changes_xml =~ s/&/&/g if ($group);
# all this flesh in the skin
my $html = read_skin('recent-old');
my $xml =
'' .
qq(\n\n") .
$old_changes_legend .
$changes_xml .
"\n";
fill_in( $html,
{%standard_substitutions,
'n' => $num,
'data' => $xml} );
}
### $text = get_page_content($title) # Get the contents of a page. #############
sub get_page_content {
my ($title) = @_;
page_exists($title)
? (page_contents($title) or err("Error reading contents of page $page: $!"))
: fill_in($empty_content, {'title' => $title});
}
### $html = show_page($title, $skin, %vars, $hide_optional) ####################
### Insert %vars into $skin, $hide_optional skin parts if necessary.
sub show_page {
my ($title, $skin, $vars, $hide_optional) = @_;
my $html = read_skin($skin);
$html =~ s'.*?''sg
if ($hide_optional);
fill_in( $html,
{%standard_substitutions,
%$vars,
'title' => $title,
'author' => author_name()} );
}
################################################################################
# U s e r s M a n a g e m e n t #
################################################################################
### $id = new_user() # Generate ID and corresponding cookie for new user #######
sub new_user {
my $id = time_now() . int rand(10000);
$user_cookie = CGI::cookie(
-name => $cookie_name,
-value => $id,
-path => '/',
-expires => '+3y');
return $id;
}
### $name = author_name() # Get the name that the author entered. ##############
sub author_name {
my $author = pop_cgi_param('author');
return $user_name unless ($author =~ /\S/);
convert_to_link_pattern($author)
unless (in_array('new', \@disabled_actions)
or in_array('author', \@disabled_actions));
if ($author ne $user_name) {
change_user_name($user_id, $author)
#and log_event("User name $user_name changed name to $author")
or log_error("Could open user $user_id file for renaming to $author: $!");
}
return $author;
}
### $is_banned = banned_user() #################################################
### Is the current user banned from making changes
sub banned_user {
return 0 if (scalar(@banned_users) == 0);
if (CGI::cookie($cookie_name)) { # not a new user
foreach $id (@banned_users) {
return 1 if ($user_id eq $id);
}
return 0;
}
return 1;
}
### check_permissions($title, $action) #########################################
### Output error message if the user is banned or the page is static.
sub check_permissions {
if (is_static($_[0])) {
err("This page is static and cannot be changed.");
}
if (banned_user()) {
err("Problem processing user request.");
}
}
### $is_it = is_static($title) # Return true if this is a static page. #########
sub is_static {
my $title = lc(shift);
return 1 if $static_site;
foreach $static (@static_titles) {
return 1 if ($title eq lc($static));
}
return 0;
}
################################################################################
# H T M L C o n v e r s i o n #
################################################################################
sub layout {
link_implicitly htmlize @_;
}
sub layout_page {
my $page = get_page_content(shift);
my $inc = qr(([^\]]+));
# insert inclusions before conversion
$page =~ s/\[->$inc\]/&include_content($1)/eg;
# mark inclusions to be inserted after conversion
my @inclusions = $page =~ /\[<-$inc\]/g;
if (scalar @inclusions) {
for (my $i = 0; $page =~ s/\[<-$inc\]/[~$i~]/; ++$i) {}
}
# convert to linked HTML
my $result = layout($page, @_);
# insert inclusions after conversion
$result =~ s/\[~(\d+)~\]/&include_content($inclusions[$1])/eg;
return $result;
}
sub include_content {
my $inc = fill_in(shift, \%standard_substitutions);
my $content;
my $file_name = qr([\w\-+.]+);
if ($inc =~ /^(?:(\w+):)?($file_name)$/) { # file from a known $dir
my $dir = $1 ? $$1 : $include_dir;
my $path = $dir . $2;
return $inc unless -e $path;
my $author = author_name(); # removes it from the query
my %extra_params = CGI::Vars();
$content = fill_in(read_whole_file($path),
{%standard_substitutions, %extra_params, 'author' => $author}
);
} elsif ($inc =~ /^($file_name)\?(.*)$/o) { # local Perl script
{
author_name(); # removes it from the query
my $extra_params = join('&', map {"$_=" . CGI::param($_)} CGI::param());
$extra_params = '&' . $extra_params if ($extra_params);
package IncludedScript;
$chiq_param = $2 . $extra_params; # global so that it can be used in the included script
$content = do "$main::include_dir$1";
}
unless (defined $content) {
$content = $@
? "[Error parsing $inc: $@]"
: "[Error reading $inc: $!]";
undef $@; # in case there are several included scripts in one page
}
}
return $content;
}
################################################################################
# S i t e U s a g e #
################################################################################
### $xml_tag = change2xml(\%titles, \%authors) #################################
### Convert change data to XML segment.
### $_ - change data
sub change2xml {
my ($titles, $authors) = @_;
my ($change_id, $time, $author_id, $title, $author, $action) = split(/\t/o);
my $pid = $titles->{$title};
my $uid = $authors->{$author};
my $date_time = xml_time($time);
qq();
}
### $xml_tag = old_change2xml() # Old version of change2xml(). #################
### $_ - change data
sub old_change2xml {
my ($change_id, $time, $author_id, $title, $author, $action) = split(/\t/o);
"\t\n" .
"\t\t$change_id\n" .
"\t\t" . old_xml_time($time) . "\n" .
"\t\t" . link_implicitly($title) . "\n" .
"\t\t" . layout($author) . "\n" .
"\t\t$action\n" .
"\t\n";
}
### log_change($title, $author, $action) # Add an entry to the $change_log. ####
sub log_change {
my @change = map {lc} @_;
# read the recent changes
my @last_changes = ();
if (open(RLOG, $recent_changes)) {
@last_changes = ;
close RLOG;
}
my ($change_id, $time, $uid, $title, $author, $action) =
@last_changes ? split(/\t/, lc($last_changes[0])) : 0;
# check if this is a distinct change
my $distinct = 0;
if (($title ne $change[0]) or ($uid ne $user_id) or ($author ne $change[1])) {
$change_id++;
$distinct = 1;
}
# format the change with its own ID and timestamp
my $change = join("\t", ($change_id, time_now(), $user_id, @change)) . "\n";
# update the big change log
if (open(LOG, ">> $change_log")) {
print LOG $change;
close LOG;
}
# update the recent changes log
if ($distinct) {
pop(@last_changes) if (@last_changes >= $recent_changes_num);
unshift @last_changes, $change;
if (open(RLOG, "> $recent_changes")) {
print RLOG @last_changes;
close RLOG;
}
}
}
### log_visit($title) # Mark when the user has visited this page. ##############
sub log_visit {
return if ($user_cookie ne '');
my ($title) = @_;
my $time = time_now();
log_user_visit($user_id, $time, lc($title), $group)
or log_error("Could not open visits file $user_id for logging $title: $!");
if (open(LOG, ">> $view_log")) {
print LOG $time, "\t$user_id\t$title\t$group\n";
close LOG;
}
}
### $xml_tag = visit2xml(\%titles) # Format the visit data in XML. #############
### $_ - visit data
sub visit2xml {
chomp;
my ($titles) = @_;
my ($title, $time, $title_group) = split(/\t/);
return ''
if (($title_group eq $group) and defined($titles->{$title}) );
} # TODO: move to User.pm?
### $xml_tag = title2xml($tag, $title, $id) # XML tag representing $title. #####
sub title2xml {
my ($tag, $title, $id) = @_;
my $is_link = page_exists($title) ? ''
: ( (in_array('new', \@disabled_actions) or $title !~ /^$Link::link_pattern$/)
? ' l="-2"' : ' l="-1"' );
convert_xml_entities($title);
qq(<$tag n="$id" s="$title"$is_link/>);
} # TODO: move to Link.pm?
################################################################################
# T e x t M a n i p u l a t i o n #
################################################################################
### $text = fill_in($skin, {field1 => value1, field2 => value2 ... }) ##########
### Substitute values into a string like Perl does.
### $skin - string containing the named fields to fill in.
### Example: "Hello $user".
### $vars - hash reference with field names and values to fill in.
### Example: {'user' => 'Bob'}.
sub fill_in {
my ($skin, $vars) = @_;
$skin =~ s/\$([a-zA-Z0-9_]+)/$vars->{$1}/g;
return $skin;
}
### $is_in = in_array($value, \@array) # Find if $value is in @array. ##########
sub in_array {
my ($value, $array) = @_;
foreach my $element (@$array) {
return 1 if ($element eq $value);
}
return;
}
### $s = read_whole_file($path) # Put file contents into a single string. ######
sub read_whole_file {
my ($path) = @_;
local $/;
open(TEXT, $path) or err("Can't open file $path for reading: $!");
my $s = ;
close(TEXT);
return $s;
}
### $s = read_skin($name) # Get the contents of a page skin file. ##############
sub read_skin {
return read_whole_file("$skin_dir$_[0].html");
}
### $title = fix_title($title) # Make the title legal or err ###################
sub fix_title {
if ($_[0] !~ /[^_\W]/) {
err("Problem decoding page title: $_[0] \nquery string: $qs");
# TODO: try to use a different charset? utf8?
}
if (!convert_to_link_pattern($_[0])) {
err("Illegal page title: $_[0].");
}
}
### convert_xml_entities($s) # Convert XML escape chars to entities. ###########
sub convert_xml_entities {
$_[0] =~ s/&/&/og;
$_[0] =~ s/</og;
$_[0] =~ s/>/>/og;
# $_[0] =~ s/'/'/og;
$_[0] =~ s/"/"/og;
}
### $time = time_now() # Return the date and time as a sortable string #########
sub time_now {
my ($sec, $min, $hour, $day, $mon, $year) = $_[0] ? localtime($_[0]) : localtime();
(1900 + $year) . two_digits($mon + 1) . two_digits($day) .
two_digits($hour) . two_digits($min) . two_digits($sec);
}
### $s = xml_time(time_now()) ##################################################
### Convert time format from yyyymmddhhmmss to date="yyyy-mm-dd" time="hh:mm:ss"
sub xml_time {
my ($t) = @_;
'd="' .
substr($t,0,4) . '-' . substr($t,4,2) . '-' . substr($t,6,2) . # yyyy-mm-dd
'" t="' .
substr($t,8,2) . ':' . substr($t,10,2) . ':' . substr($t,12,2) . # Thh:mm:ss
'"';
}
### $s = old_xml_time(time_now()) # Old version of xml_time(). #################
sub old_xml_time {
my ($t) = @_;
substr($t,0,4) . '-' . substr($t,4,2) . '-' . substr($t,6,2) . # yyyy-mm-dd
'T' . substr($t,8,2) . ':' . substr($t,10,2) . ':' . substr($t,12,2); # Thh:mm:ss
}
### $s = nice_time(time_now()) ##################################################
### Convert time format from yyyymmddhhmmss to dd/mm/yyyy hh:mm
sub nice_time {
my ($t) = @_;
substr($t,6,2) . '/' . substr($t,4,2) . '/' . substr($t,0,4) . # dd/mm/yyyy
' ' .
substr($t,8,2) . ':' . substr($t,10,2); # hh:mm
}
### $num2 = two_digits($num) # Return the two-digit representation of $num #####
sub two_digits {
($_[0] < 10) ? '0' . $_[0] : $_[0];
}
sub trim {
my $s = shift;
$s =~ s/\s+$//;
return $s;
}
sub unescape_url {
$_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
return $_[0];
}
sub url_params {
map {unescape_url($_)} split(/[&;=]/, $_[0]);
}
### @cut = cut_strings($total_length, @strings) ################################
### Cut @stirngs to fit no more than $total_length.
sub cut_strings {
my $max_length = shift;
my $current_length = 0;
for (my $i = $#_; $i >= 0; --$i) {
$current_length += length($_[$i]);
if ($current_length > $max_length) {
$_[$i] = substr($_[$i], 0, length($_[$i]) - ($current_length - $max_length));
$_[$i] =~ s/\S+$//; # cut on word end
$_[$i] .= '...'; # mark the string was cut
while (--$i >= 0) {
$_[$i] = '';
}
return;
}
}
}
### \%teaser_data = random_teaser() ############################################
### Choose a random section from the teasers page.
sub random_teaser {
return ('teaser_display' => 'none')
unless ($teasers_page_title && page_exists($teasers_page_title));
my @sections =
split( /(?:^(?:.*?\n)?\s*\{)|(?:\}\s*\n(?:[^\{].*?\n)?\s*\{)|(?:\}[^\{]*$)/s,
page_contents($teasers_page_title));
shift @sections if ($sections[0] eq '');
my @lines = split(/\n/, $sections[rand @sections]);
my $author = trim(shift @lines);
my $source = trim(pop @lines) if ($#lines > 0);
my $text = trim(join("\n", @lines));
cut_strings($max_teaser_length, $text, $source);
return (
'teaser_author' => $author,
'teaser_source' => ($source) ? '(' . link_implicitly($source) . ')' : '',
'teaser_text' => link_implicitly($text)
);
}
1;