Initial version of webperl added.
This commit is contained in:
commit
7b7fac78b3
383
Block.pm
Normal file
383
Block.pm
Normal file
@ -0,0 +1,383 @@
|
||||
## @file
|
||||
# This file contains the implementation of the base Block class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 1.2
|
||||
# @date 12 May 2009
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class Block
|
||||
# The Block class serves as the base class for all plugin block modules in
|
||||
# the system. It provides the basic constructor required to initialise a
|
||||
# plugin properly, stub functions for the two key content generation
|
||||
# functions that plugins can override to provide meaningful output, and a
|
||||
# number of general utility functions usefil for all blocks.
|
||||
#
|
||||
# Block subclasses may provide two different 'views': an inline block fragment
|
||||
# that is intended to be embedded within a page generated by another block
|
||||
# (for example, sidebar menu contents); or the complete contents of a page
|
||||
# which may be generated solely by the Block subclass, or by the subclass
|
||||
# loading other Blocks and using their inline block fragments to construct the
|
||||
# overall page content.
|
||||
package Block;
|
||||
|
||||
use HTMLValidator;
|
||||
use Utils qw(is_defined_numeric);
|
||||
|
||||
use HTML::Entities;
|
||||
use strict;
|
||||
|
||||
# Globals within this and available to subclasses
|
||||
use vars qw{$VERSION $errstr};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = 1.2;
|
||||
$errstr = '';
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# Constructor
|
||||
|
||||
## @cmethod $ new($id, $args, $cgi, $dbh, $phpbb, $template, $settings, $session, $module)
|
||||
# Create a new Block object and store the provided objects in the new object's data. id and
|
||||
# args are optional, all the remaining arguments must be provided.
|
||||
#
|
||||
# @param id The module id set for the block module's entry in the database.
|
||||
# @param args Any arguments passed to the plugin at runtime, usually pulled from the database.
|
||||
# @param cgi A reference to the script's CGI object.
|
||||
# @param dbh A database handle to talk to the database through.
|
||||
# @param phpbb A phpbb3 handle object used to perform operations on a phpbb3 database.
|
||||
# @param template A template engine module object to load templates through.
|
||||
# @param settings The global configuration hashref.
|
||||
# @param session A reference to the current session object
|
||||
# @param module The module handler object, used to load other blocks on demand.
|
||||
# @return A newly created Block object.
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
my $id = shift;
|
||||
my $args = shift;
|
||||
my $cgi = shift or return set_error("Block::new(): No cgi object specified");
|
||||
my $dbh = shift or return set_error("Block::new(): No datbase object specified");
|
||||
my $phpbb = shift or return set_error("Block::new(): No phpBB3 object specified");
|
||||
my $template = shift or return set_error("Block::new(): No template object specified");
|
||||
my $settings = shift or return set_error("Block::new(): No settings object specified");
|
||||
my $session = shift or return set_error("Block::new(): No session object specified");
|
||||
my $module = shift or return set_error("Block::new(): No module object specified");
|
||||
|
||||
my $self = {
|
||||
modid => $id,
|
||||
args => $args,
|
||||
cgi => $cgi,
|
||||
dbh => $dbh,
|
||||
phpbb => $phpbb,
|
||||
template => $template,
|
||||
settings => $settings,
|
||||
session => $session,
|
||||
module => $module,
|
||||
};
|
||||
|
||||
# Work out which block we're being invoked with
|
||||
$self -> {"block"} = is_defined_numeric($self -> {"cgi"}, "block") || $self -> {"settings"} -> {"config"} -> {"default_block"};
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# Parameter validation support functions
|
||||
|
||||
## @method @ validate_string($param, $settings)
|
||||
# Determine whether the string in the namedcgi parameter is set, clean it
|
||||
# up, and apply various tests specified in the settings. The settings are
|
||||
# stored in a hash, the recognised contents are as below, and all are optional
|
||||
# unless noted otherwise:
|
||||
#
|
||||
# required - If true, the string must have been given a value in the form.
|
||||
# default - The default string to use if the form field is empty. This is not
|
||||
# used if required is set!
|
||||
# nicename - The required 'human readable' name of the field to show in errors.
|
||||
# minlen - The minimum length of the string.
|
||||
# maxlen - The maximum length of the string.
|
||||
# chartest - A string containing a regular expression to apply to the string. If this
|
||||
# <b>matches the field</b> the validation fails!
|
||||
# chardesc - Must be provided if chartest is provided. A description of why matching
|
||||
# chartest fails the validation.
|
||||
# formattest - A string containing a regular expression to apply to the string. If the
|
||||
# string <b>does not</b> match the regexp, validation fails.
|
||||
# formatdesc - Must be provided if formattest is provided. A description of why not
|
||||
# matching formattest fails the validation.
|
||||
#
|
||||
# @param param The name of the cgi parameter to check/
|
||||
# @param settings A reference to a hash of settings to control the validation
|
||||
# done to the string.
|
||||
# @return An array of two values: the first contains the text in the parameter, or
|
||||
# as much of it as can be salvaged, while the second contains an error message
|
||||
# or undef if the text passes all checks.
|
||||
sub validate_string {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
my $settings = shift;
|
||||
|
||||
# Grab the parameter value, fall back on the default if it hasn't been set.
|
||||
my $text = $self -> {"cgi"} -> param($param);
|
||||
|
||||
# Handle the situation where the parameter has not been provided at all
|
||||
if(!defined($text) || $text eq '' || (!$text && $settings -> {"nonzero"})) {
|
||||
# If the parameter is required, return empty and an error
|
||||
if($settings -> {"required"}) {
|
||||
return ("", $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_NOTSET", "", {"***field***" => $settings -> {"nicename"}}));
|
||||
# Otherwise fall back on the default.
|
||||
} else {
|
||||
$text = $settings -> {"default"} || "";
|
||||
}
|
||||
}
|
||||
|
||||
# If there's a test regexp provided, apply it
|
||||
my $chartest = $settings -> {"chartest"};
|
||||
return ($text, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_BADCHARS", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***desc***" => $settings -> {"chardesc"}}))
|
||||
if($chartest && $text =~ /$chartest/);
|
||||
|
||||
# Is there a format check provided, if so apply it
|
||||
my $formattest = $settings -> {"formattest"};
|
||||
return ($text, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_BADFORMAT", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***desc***" => $settings -> {"formatdesc"}}))
|
||||
if($formattest && $text !~ /$formattest/);
|
||||
|
||||
# Convert all characters in the string to safe versions
|
||||
$text = encode_entities($text);
|
||||
|
||||
# Now trim spaces
|
||||
$text =~ s/^\s+//;
|
||||
$text =~ s/\s+$//;
|
||||
|
||||
# Get here and we have /something/ for the parameter. If the maximum length
|
||||
# is specified, does the string fit inside it? If not, return as much of the
|
||||
# string as is allowed, and an error
|
||||
return (substr($text, 0, $settings -> {"maxlen"}), $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_TOOLONG", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***maxlen***" => $settings -> {"maxlen"}}))
|
||||
if($settings -> {"maxlen"} && length($text) > $settings -> {"maxlen"});
|
||||
|
||||
# Is the string too short (we only need to check if it's required or has content) ? If so, store it and return an error.
|
||||
return ($text, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_TOOSHORT", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***minlen***" => $settings -> {"minlen"}}))
|
||||
if(($settings -> {"required"} || length($text)) && $settings -> {"minlen"} && length($text) < $settings -> {"minlen"});
|
||||
|
||||
# Get here and all the tests have been passed or skipped
|
||||
return ($text, undef);
|
||||
}
|
||||
|
||||
|
||||
## @method @ validate_options($param, $settings)
|
||||
# Determine whether the value provided for the specified parameter is valid. This will
|
||||
# either look for the value specified in an array, or in a database table, depending
|
||||
# on the value provided for source in the settings hash. Valid contents for settings are:
|
||||
#
|
||||
# required - If true, the option can not be "".
|
||||
# default - A default value to return if the option is '' or not present, and not required.
|
||||
# source - The source of the options. If this is a reference to an array, the
|
||||
# value specified for the parameter is checked agains the array. If this
|
||||
# if a string, the option is checked against the table named in the string.
|
||||
# where - The 'WHERE' clause to add to database queries. Required when source is a
|
||||
# string, otherwise it is ignored.
|
||||
# nicename - Required, human-readable version of the parameter name.
|
||||
#
|
||||
# @param param The name of the cgi parameter to check.
|
||||
# @param settings A reference to a hash of settings to control the validation
|
||||
# done to the parameter.
|
||||
# @return An array of two values: the first contains the value in the parameter, or
|
||||
# as much of it as can be salvaged, while the second contains an error message
|
||||
# or undef if the parameter passes all checks.
|
||||
sub validate_options {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
my $settings = shift;
|
||||
|
||||
my $value = $self -> {"cgi"} -> param($param);
|
||||
|
||||
# Bomb if the value is not set and it is required.
|
||||
return ("", $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_NOTSET", "", {"***field***" => $settings -> {"nicename"}}))
|
||||
if($settings -> {"required"} && (!defined($value) || $value eq ''));
|
||||
|
||||
# If the value not specified and not required, we can just return immediately
|
||||
return ($settings -> {"default"}, undef) if(!defined($value) || $value eq "");
|
||||
|
||||
# Determine how we will check it. If the source is an array reference, we do an array check
|
||||
if(ref($settings -> {"source"}) eq "ARRAY") {
|
||||
foreach my $check (@{$settings -> {"source"}}) {
|
||||
return ($value, undef) if($check eq $value);
|
||||
}
|
||||
|
||||
# If the source is not a reference, we assue it is the table name to check
|
||||
} elsif(not ref($settings -> {"source"})) {
|
||||
my $checkh = $self -> {"dbh"} -> prepare("SELECT *
|
||||
FROM ".$settings -> {"source"}."
|
||||
".$settings -> {"where"});
|
||||
# Check for the value in the table...
|
||||
$checkh -> execute($value)
|
||||
or return (undef, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_DBERR", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***dberr***" => $self -> {"dbh"} -> errstr}));
|
||||
my $checkr = $checkh -> fetchrow_arrayref();
|
||||
|
||||
# If we have a match, the value is valid
|
||||
return ($value, undef) if($checkr);
|
||||
}
|
||||
|
||||
# Get here and validation has failed. We can't rely on the value at all, so return
|
||||
# nothing for it, and an error
|
||||
return (undef, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_BADOPT", "", {"***field***" => $settings -> {"nicename"}}));
|
||||
}
|
||||
|
||||
|
||||
## @method @ validate_htmlarea($param, $settings)
|
||||
# Attempt to validate the contents of a html area. This is an excessively complicated
|
||||
# job and is, ultimately, never going to be 100% secure - the code needs to be put through
|
||||
# filters and validation by a html validator before we can be be even remotely sure it
|
||||
# is vaguely safe. Even then, there is a small possibility that a malicious user can
|
||||
# carefully craft something to bypass the checks.
|
||||
#
|
||||
# @param param The name of the textarea to check.
|
||||
# @param settings A reference to a hasn containing settings to control the validation.
|
||||
sub validate_htmlarea {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
my $settings = shift;
|
||||
|
||||
# first we need the textarea contents...
|
||||
my $text = $self -> {"cgi"} -> param($param);
|
||||
# If the text area is empty, deal with the whole default/required malarky
|
||||
if(!defined($text)) {
|
||||
# If the parameter is required, return empty and an error
|
||||
if($settings -> {"required"}) {
|
||||
return ("", $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_NOTSET", "", {"***field***" => $settings -> {"nicename"}}));
|
||||
# Otherwise fall back on the default.
|
||||
} else {
|
||||
$text = $settings -> {"default"} || "";
|
||||
}
|
||||
}
|
||||
# Don't bother doing anything if the text is empty at this point
|
||||
return ("", undef) if(!$text || length($text) == 0);
|
||||
|
||||
# Now we get to the actual validation and stuff. Begin by scrubbing any tags
|
||||
# and other crap we don't want out completely. As far as I can tell, this should
|
||||
# always result in some kind...
|
||||
$text = scrub_html($text);
|
||||
|
||||
# ... but check, just in case
|
||||
return ("", $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_SCRUBFAIL", "", {"***field***" => $settings -> {"nicename"}}))
|
||||
if(!defined($text));
|
||||
|
||||
# Explicitly nuke any CDATA sections that might have got through, as they have
|
||||
# no bloody business being there at all
|
||||
$text =~ s{<![CDATA[.*?]]>}{}gio;
|
||||
|
||||
# Load the text into the testing hardness now, so it appears like a valid chunk of html
|
||||
# to tidy and the validator...
|
||||
my $xhtml = $self -> {"template"} -> load_template("validator_harness.tem", {"***body***" => $text});
|
||||
|
||||
# Throw the xhtml through tidy to make sure it is actually xhtml
|
||||
# This will result in undef if tidy failed catastrophically...
|
||||
my $tidied = tidy_html($xhtml);
|
||||
return ("", , $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_TIDYFAIL", "", {"***field***" => $settings -> {"nicename"}}))
|
||||
if(!$tidied);
|
||||
|
||||
# Now we can go ahead and check with the validator to see whether the tidied
|
||||
# code is valid xhtml
|
||||
my $valid = check_xhtml($tidied);
|
||||
|
||||
# Strip out the harness
|
||||
$tidied =~ s{^.*<body>\s*(.*)\s*</body>\s*</html>\s*$}{$1}is;
|
||||
|
||||
# Zero indicates that there were no errors - the html is valid
|
||||
if($valid == 0) {
|
||||
return ($tidied, undef);
|
||||
|
||||
# If the return from check_xhtml is one or more digits, it is an error count
|
||||
} elsif($valid =~ /^\d+$/) {
|
||||
return ($tidied, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_CHKERRS", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***error***" => $valid}));
|
||||
|
||||
# Otherwise it should be a failure message
|
||||
} else {
|
||||
return ($tidied, $self -> {"template"} -> replace_langvar("BLOCK_VALIDATE_CHKFAIL", "", {"***field***" => $settings -> {"nicename"},
|
||||
"***error***" => $valid}));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Display functions
|
||||
|
||||
## @method @ build_error_box($message)
|
||||
# Generate the contents of a system error message to send back to the user.
|
||||
# This wraps the template message_box() function as a means to make error
|
||||
# messages easier to show.
|
||||
#
|
||||
# @param message The message explaining the problem that triggered the error.
|
||||
# @return An array of two values. The first is the page title, the second is
|
||||
# the text of the error box.
|
||||
sub build_error_box {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
|
||||
my $title = $self -> {"template"} -> replace_langvar("BLOCK_ERROR_TITLE");
|
||||
$message = $self -> {"template"} -> message_box($self -> {"template"} -> replace_langvar("BLOCK_ERROR_TITLE"),
|
||||
'info',
|
||||
$self -> {"template"} -> replace_langvar("BLOCK_ERROR_SUMMARY"),
|
||||
$self -> {"template"} -> replace_langvar("BLOCK_ERROR_TEXT", {"***error***" => $message}));
|
||||
return ($title, $message);
|
||||
}
|
||||
|
||||
|
||||
## @method $ block_display()
|
||||
# Produce the string containing this block's 'block fragment' if it has one. By default,
|
||||
# this will return a string containing an error message. If block fragment content is
|
||||
# needed, this must be overridden in the subclass.
|
||||
#
|
||||
# @return The string containing this block's content fragment.
|
||||
sub block_display {
|
||||
my $self = shift;
|
||||
|
||||
return "<p class=\"error\">".$self -> {"template"} -> replace_langvar("BLOCK_BLOCK_DISPLAY")."</p>";
|
||||
}
|
||||
|
||||
|
||||
## @method $ page_display()
|
||||
# Produce the string containing this blocks full page content, if it provides one.
|
||||
# By default, this will return a string containing an error message, override it to
|
||||
# generate pages in subclasses.
|
||||
#
|
||||
# @return The string containing this block's page content.
|
||||
sub page_display {
|
||||
my $self = shift;
|
||||
|
||||
return "<p class=\"error\">".$self -> {"template"} -> replace_langvar("BLOCK_PAGE_DISPLAY")."</p>";
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Internal
|
||||
|
||||
## @fn $ set_error($errstr)
|
||||
# Set a class error string. This will always return undef, and can be used to
|
||||
# set an error message and return undef at the same time.
|
||||
#
|
||||
# @param errstr The error to store in the global errstr variable.
|
||||
# @return undef, always.
|
||||
sub set_error { $errstr = shift; return undef; }
|
||||
|
||||
1;
|
||||
301
ConfigMicro.pm
Normal file
301
ConfigMicro.pm
Normal file
@ -0,0 +1,301 @@
|
||||
## @file
|
||||
# This file contains the implementation of a compact, simple congifuration
|
||||
# loading and saving class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 2.0
|
||||
# @date 22 Feb 2009
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class ConfigMicro
|
||||
# A simple configuration class intended to allow ini files to be read and saved. This
|
||||
# provides the means to read the contents of an ini file into a hash and saving such a
|
||||
# hash out as an ini file.
|
||||
#
|
||||
# @par Example
|
||||
#
|
||||
# Given an ini file of the form
|
||||
# <pre>[sectionA]
|
||||
# keyA = valueA
|
||||
# keyB = valueB
|
||||
#
|
||||
# [sectionB]
|
||||
# keyA = valueC
|
||||
# keyC = valueD</pre>
|
||||
# this will load the file into a hash of the form
|
||||
# <pre>{ "sectionA" => { "keyA" => "valueA",
|
||||
# "keyB" => "valueB" },
|
||||
# "sectionB" => { "keyA" => "valueC",
|
||||
# "keyC" => "valueD" }
|
||||
# }</pre>
|
||||
package ConfigMicro;
|
||||
|
||||
require 5.005;
|
||||
use DBI;
|
||||
use strict;
|
||||
|
||||
our ($VERSION, $errstr);
|
||||
|
||||
BEGIN {
|
||||
$VERSION = 2.0;
|
||||
$errstr = '';
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# Constructor and basic file-based config functions
|
||||
|
||||
## @cmethod $ new(%args)
|
||||
# Create a new ConfigMicro object. This creates an object that provides functions
|
||||
# for loading and saving configurations, and pulling config data from a database.
|
||||
# Meaningful options for this are:
|
||||
# filename - The name of the configuration file to read initial settings from. This
|
||||
# is optional, and if not specified you will get an empty object back.
|
||||
# You may also pass in one or more initial configuration settings.
|
||||
# @param args A hash of key, value pairs to initialise the object with.
|
||||
# @return A new ConfigMicro object, or undef if a problem occured.
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
my $filename = shift;
|
||||
|
||||
# Object constructors don't get much more minimal than this...
|
||||
my $self = { "__privdata" => { "modified" => 0 },
|
||||
@_,
|
||||
};
|
||||
|
||||
my $obj = bless $self, $class;
|
||||
|
||||
# Return here if we have no filename to load from
|
||||
return $obj if(!$filename);
|
||||
|
||||
# Otherwise, try to read the file
|
||||
return $obj if($obj -> read($filename));
|
||||
|
||||
# Get here and things have gone wahoonie-shaped
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
## @method $ read($filename)
|
||||
# Read a configuration file into a hash. This will process the file identified by
|
||||
# the specified filename, attempting to load its contents into a hash. Any key/value
|
||||
# pairs that occur before a [section] header are added to the '_' section.
|
||||
#
|
||||
# @param filename The name of the file to read the config data from.
|
||||
# @return True if the configuration has been loaded sucessfully, false otherwise.
|
||||
sub read {
|
||||
my $self = shift;
|
||||
my $filename = shift or return set_error("No file name provided");
|
||||
|
||||
# The current section, default it to '_' in case there is no leading [section]
|
||||
my $section = "_";
|
||||
|
||||
# TODO: should this return the whole name? Possibly a security issue here
|
||||
return set_error("Failed to open '$filename': $!")
|
||||
if(!open(CFILE, "< $filename"));
|
||||
|
||||
my $counter = 0;
|
||||
while(my $line = <CFILE>) {
|
||||
chomp($line);
|
||||
++$counter;
|
||||
|
||||
# Skip comments and empty lines
|
||||
next if($line =~ /^\s*(\#|;|\z)/);
|
||||
|
||||
# Handle section headers, allows for comments after the ], but [foo #comment] will
|
||||
# treat the section name as 'foo #comment'!
|
||||
if($line =~ /^\s*\[([^\]]+)\]/) {
|
||||
$section = $1;
|
||||
|
||||
# Attribues with quoted values. value can contain anything other than "
|
||||
} elsif($line =~ /^\s*([\w\-]+)\s*=\s*\"([^\"]+)\"/ ) {
|
||||
$self -> {$section} -> {$1} = $2;
|
||||
|
||||
# Handle attributes without quoted values - # or ; at any point will mark comments
|
||||
} elsif($line =~ /^\s*([\w\-]+)\s*=\s*([^\#;]+)/ ) {
|
||||
$self -> {$section} -> {$1} = $2;
|
||||
|
||||
# bad input...
|
||||
} else {
|
||||
close(CFILE);
|
||||
return set_error("Syntax error on line $counter: '$line'");
|
||||
}
|
||||
}
|
||||
|
||||
close(CFILE);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
## @method $ text_config(@skip)
|
||||
# Create a text version of the configuration stored in this ConfigMicro object.
|
||||
# This creates a string representation of the configuration suitable for writing to
|
||||
# an ini file or otherwise printing.
|
||||
#
|
||||
# @param skip If you specify one or more section names, the sections will not be
|
||||
# added to the string generated by this function.
|
||||
# @return A string representation of this ConfigMicro's config settings.
|
||||
sub text_config {
|
||||
my $self = shift;
|
||||
my @skip = @_;
|
||||
my $result;
|
||||
|
||||
my ($key, $skey);
|
||||
foreach $key (sort(keys(%$self))) {
|
||||
# Skip the internal settings
|
||||
next if($key eq "__privdata");
|
||||
|
||||
# If we have any sections to skip, and the key is one of the ones to skip... skip!
|
||||
next if(scalar(@skip) && grep($key, @skip));
|
||||
|
||||
# Otherwise, we want to start a new section. Entries in the '_' section go out
|
||||
# with no section header.
|
||||
$result .= "[$key]\n" if($key ne "_");
|
||||
|
||||
# write out all the key/value pairs in the current section
|
||||
foreach $skey (sort(keys(%{$self -> {$key}}))) {
|
||||
$result .= $skey." = \"".$self -> {$key} -> {$skey}."\"\n";
|
||||
}
|
||||
$result .= "\n";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
## @method $ write($filename, @skip)
|
||||
# Save a configuration hash to a file. Writes the contents of the configuration to
|
||||
# a file, formatting the output as an ini-style file.
|
||||
#
|
||||
# @param filename The file to save the configuration to.
|
||||
# @param skip An optional list of names of sections to ignore when writing the
|
||||
# configuration.
|
||||
# @return true if the configuration was saved successfully, false if a problem
|
||||
# occurred.
|
||||
sub write {
|
||||
my $self = shift;
|
||||
my $filename = shift or return set_error("No file name provided");
|
||||
my @skip = @_;
|
||||
|
||||
# Do nothing if the config has not been modified.
|
||||
return 0 if(!$self -> {"__privdata"} -> {"modified"});
|
||||
|
||||
return set_error("Failed to save '$filename': $!")
|
||||
if(!open(CFILE, "> $filename"));
|
||||
|
||||
print CFILE $self -> text_config(@skip);
|
||||
|
||||
close(CFILE);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Database config functions
|
||||
|
||||
## @method $ load_db_config($dbh, $table, $name, $value)
|
||||
# Load settings from a database table. This will pull name/value pairs from the
|
||||
# named database table, storing them in a hashref called 'config'.
|
||||
#
|
||||
# @param dbh A database handle to issue queries through.
|
||||
# @param table The name of the table containing key/value pairs.
|
||||
# @param name Optional name of the table column for the key name, defaults to 'name'
|
||||
# @param value Optional name of the table column for the value, defaults to 'value'
|
||||
# @return true if the configuration table was read into the config object, false
|
||||
# if a problem occurred.
|
||||
sub load_db_config {
|
||||
my $self = shift;
|
||||
my $dbh = shift or return set_error("No database handle provided");
|
||||
my $table = shift or return set_error("Settings table name not provided");
|
||||
my $name = shift || "name";
|
||||
my $value = shift || "value";
|
||||
|
||||
my $confh = $dbh -> prepare("SELECT * FROM $table");
|
||||
$confh -> execute()
|
||||
or return set_error("Unable to execute SELECT query - ".$dbh -> errstr);
|
||||
|
||||
my $row;
|
||||
while($row = $confh -> fetchrow_hashref()) {
|
||||
$self -> {"config"} -> {$row -> {$name}} = $row -> {$value};
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
## @method $ save_db_config($dbh, $table, $name, $value)
|
||||
# Save the database configuration back into the database table. This will write the
|
||||
# key/value pairs inside the 'config' configuration hash back into the database.
|
||||
#
|
||||
# @param dbh A database handle to issue queries through.
|
||||
# @param table The name of the table containing key/value pairs.
|
||||
# @param name Optional name of the table column for the key name, defaults to 'name'
|
||||
# @param value Optional name of the table column for the value, defaults to 'value'
|
||||
# @return true if the configuration table was updated from the config object, false
|
||||
# if a problem occurred.
|
||||
sub save_db_config {
|
||||
my $self = shift;
|
||||
my $dbh = shift or return set_error("No database handle provided");
|
||||
my $table = shift or return set_error("Settings table name not provided");
|
||||
my $name = shift || "name";
|
||||
my $value = shift || "value";
|
||||
|
||||
my $confh = $dbh -> prepare("UPDATE $table SET `$value` = ? WHERE `$name` = ?");
|
||||
|
||||
foreach my $key (keys(%{$self -> {"config"}})) {
|
||||
$confh -> execute($self -> {"config"} -> {$key}, $key)
|
||||
or return set_error("Unable to execute UPDATE query - ".$dbh -> errstr);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
## @method $ set_db_config($dbh, $table, $name, $value, $namecol, $valcol)
|
||||
# Set the named configuration variable to the specified calye.
|
||||
#
|
||||
# @param dbh A database handle to issue queries through.
|
||||
# @param table The name of the table containing key/value pairs.
|
||||
# @param name The name of the variable to update.
|
||||
# @param value The value to change the variable to.
|
||||
# @param namecol Optional name of the table column for the key name, defaults to 'name'
|
||||
# @param valuecol Optional name of the table column for the value, defaults to 'value'
|
||||
# @return true if the config variable was changed, false otherwise.
|
||||
sub set_db_config {
|
||||
my $self = shift;
|
||||
my $dbh = shift or return set_error("No database handle provided");
|
||||
my $table = shift or return set_error("Settings table name not provided");
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
my $namecol = shift || "name";
|
||||
my $valuecol = shift || "value";
|
||||
|
||||
my $confh = $dbh -> prepare("UPDATE $table SET `$valuecol` = ? WHERE `$namecol` = ?");
|
||||
$confh -> execute($value, $name)
|
||||
or return set_error("Unable to execute UPDATE query - ".$dbh -> errstr);
|
||||
|
||||
$self -> {"config"} -> {$name} = $value;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# Error functions
|
||||
|
||||
sub set_error { $errstr = shift; return undef; }
|
||||
|
||||
1;
|
||||
207
HTMLValidator.pm
Normal file
207
HTMLValidator.pm
Normal file
@ -0,0 +1,207 @@
|
||||
## @file
|
||||
# HTML validation and checking functions. This file contains functions to
|
||||
# support the cleaning and checking of html using a combination of
|
||||
# HTML::Scrubber to do first-stage cleaning, HTML::Tidy to clear up the
|
||||
# content as needed, and the W3C validator via the WebService::Validator::HTML::W3C
|
||||
# to ensure that the xhtml generated by HTML::Tidy is valid.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 1.0
|
||||
# @date 22 May 09
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
package HTMLValidator;
|
||||
|
||||
require Exporter;
|
||||
use Encode;
|
||||
use HTML::Scrubber;
|
||||
use HTML::Tidy;
|
||||
use WebService::Validator::HTML::W3C;
|
||||
use strict;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(scrub_html tidy_html check_xhtml);
|
||||
|
||||
our $VERSION = 1.0;
|
||||
|
||||
|
||||
# =============================================================================
|
||||
# HTML::Scrubber related code
|
||||
|
||||
# List of tags we are going to let through, lifted from the security
|
||||
# discussion on http://wiki.moxiecode.com/index.php/TinyMCE:Security
|
||||
# Several tags removed to make xhtml conformance easier and to remove
|
||||
# deprecated and eyestabbery.
|
||||
my @allow = ("a", "b", "blockquote", "br", "caption", "col", "colgroup", "comment",
|
||||
"em", "h1", "h2", "h3", "h4", "h5", "h6", "hr", "img", "li", "ol", "p",
|
||||
"pre", "small", "span", "strong", "sub", "sup", "table", "tbody", "td",
|
||||
"tfoot", "th", "thead", "tr", "tt", "ul");
|
||||
|
||||
# Explicit rules for allowed tags, required to provide per-tag tweaks to the filter.
|
||||
my @rules = (
|
||||
img => {
|
||||
src => qr{^(?:http|https)://}i,
|
||||
alt => 1,
|
||||
style => 1,
|
||||
width => 1,
|
||||
height => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
a => {
|
||||
href => qr{^(?:http|https)://}i,
|
||||
name => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
table => {
|
||||
cellspacing => 1,
|
||||
cellpadding => 1,
|
||||
style => 1,
|
||||
class => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
td => {
|
||||
colspan => 1,
|
||||
rowspan => 1,
|
||||
style => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
blockquote => {
|
||||
cite => qr{^(?:http|https)://}i,
|
||||
style => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
span => {
|
||||
class => 1,
|
||||
style => 1,
|
||||
title => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
div => {
|
||||
class => 1,
|
||||
style => 1,
|
||||
title => 1,
|
||||
'*' => 0,
|
||||
},
|
||||
);
|
||||
|
||||
# Default ruleset applied when no explicit rule is found for a tag.
|
||||
my @default = (
|
||||
0 => # default rule, deny all tags
|
||||
{
|
||||
'href' => qr{^(?:http|https)://[-\w]+(?:\.[-\w]+)/}i, # Force basic URL forms
|
||||
'src' => qr{^(?:http|https)://[-\w]+(?:\.[-\w]+)/}i, # Force basic URL forms
|
||||
'style' => qr{^((?!expr|java|script|eval|\r|\n|\t).)*$}i, # kill godawful insane dynamic css shit (who the fuck thought this would be a good idea?)
|
||||
'name' => 1,
|
||||
'*' => 0, # default rule, deny all attributes
|
||||
}
|
||||
);
|
||||
|
||||
|
||||
## @fn $ scrub_html($html)
|
||||
# Remove dangerous/unwanted elements and attributes from a html document. This will
|
||||
# use HTML::Scrubber to remove the elements and attributes from the specified html
|
||||
# that could be used maliciously. There is still the potential for a clever attacker
|
||||
# to craft a page that bypasses this, but that exists pretty much regardless once
|
||||
# html input is permitted...
|
||||
#
|
||||
# @param html The string containing the html to clean up
|
||||
# @return A string containing the scrubbed html.
|
||||
sub scrub_html {
|
||||
my $html = shift;
|
||||
|
||||
# Die immediately if there's a nul character in the string, that should never, ever be there.
|
||||
die_log("HACK ATTEMPT", "Hack attempt detected. Sod off.")
|
||||
if($html =~ /\0/);
|
||||
|
||||
# First, a new scrubber
|
||||
my $scrubber = HTML::Scrubber -> new(allow => \@allow,
|
||||
rules => \@rules,
|
||||
default => \@default,
|
||||
comment => 0,
|
||||
process => 0);
|
||||
|
||||
# fix problems with the parser setup. This is hacky and nasty,
|
||||
# but from CPAN's bug tracker, this appears to have been present for
|
||||
# the past 3 years at least.
|
||||
if(exists $scrubber -> {_p}) {
|
||||
# Allow for <img />, <br/>, <p></p>, and so on
|
||||
$scrubber -> {_p} -> empty_element_tags(1);
|
||||
|
||||
# Make sure that HTML::Parser doesn't scream about utf-8 from the form
|
||||
$scrubber -> {_p} -> utf8_mode(1)
|
||||
if($scrubber -> {_p} -> can('utf8_mode'));
|
||||
}
|
||||
|
||||
# And throw the html through the scrubber
|
||||
return $scrubber -> scrub($html);
|
||||
}
|
||||
|
||||
|
||||
# ==============================================================================
|
||||
# HTML::Tidy related code
|
||||
|
||||
## @fn $ tidy_html($html, $options)
|
||||
# Pass a chunk of html through htmltidy. This should produce well-formed xhtml
|
||||
# that can be passed on to the validator to check.
|
||||
#
|
||||
# @param html The string containing html to tidy.
|
||||
# @param options A reference to a hash containing options to pass to HTML::Tidy.
|
||||
# @return The html generated by htmltidy.
|
||||
sub tidy_html {
|
||||
my $html = shift;
|
||||
my $options = shift;
|
||||
|
||||
# Create a new tidy object
|
||||
my $tidy = HTML::Tidy->new($options);
|
||||
return $tidy -> clean($html);
|
||||
}
|
||||
|
||||
|
||||
# ==============================================================================
|
||||
# WebService::Validator::HTML::W3C related code
|
||||
|
||||
## @fn @ check_xhtml($xhtml, $options)
|
||||
# Check that the xhtml is valid by passing it through the W3C validator service.
|
||||
# If this is unable to contact the validation service, it will return the reason,
|
||||
# otherwise the number of errors will be returned (0 indicates that the xhtml
|
||||
# passed validation with no errors)
|
||||
#
|
||||
# @param xhtml The xhtml to validate with the W3C validator
|
||||
# @param options A hash containing options to pass to the validator module.
|
||||
# Currently supports 'timeout' and 'uri'.
|
||||
# @return The number of errors during validation (0 = valid), or a string
|
||||
# from the validator module explaining why the validation bombed.
|
||||
sub check_xhtml {
|
||||
my $xhtml = shift;
|
||||
my $options = shift;
|
||||
|
||||
# Create a validator
|
||||
my $validator = WebService::Validator::HTML::W3C -> new(http_timeout => $options -> {"timeout"},
|
||||
validator_uri => $options -> {"uri"});
|
||||
# Throw the xhtml at the validator
|
||||
if($validator -> validate_markup(Encode::encode_utf8($xhtml))) {
|
||||
# return 0 to indicate it is valid
|
||||
return 0
|
||||
if($validator -> is_valid());
|
||||
|
||||
# otherwise, the xhtml is not valid, so return the error count
|
||||
return $validator -> num_errors();
|
||||
}
|
||||
|
||||
# Get here and the validation request fell over, return the 'oh shit' result...
|
||||
return $validator -> validator_error();
|
||||
}
|
||||
|
||||
1;
|
||||
119
Logging.pm
Normal file
119
Logging.pm
Normal file
@ -0,0 +1,119 @@
|
||||
## @file
|
||||
# System-wide logging functions. The functions in this file provide logging and
|
||||
# printing facilities for the whole system.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 1.0
|
||||
# @date 2 March 2009
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class
|
||||
# System-wide logging functions. The functions in this file provide logging and
|
||||
# printing facilities for the whole system.
|
||||
#
|
||||
package Logging;
|
||||
require Exporter;
|
||||
use strict;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(warn_log die_log);
|
||||
our @EXPORT_OK = qw(start_log end_log);
|
||||
|
||||
our $VERSION = 1.0;
|
||||
|
||||
|
||||
my $logfile; # If defined, this is handle to the file that entries a written to
|
||||
my $logtime; # The time that the log file was opened
|
||||
|
||||
|
||||
## @fn void warn_log($ip, $message)
|
||||
# Write a warning message to STDERR and to a log file if it is opened. Warnings
|
||||
# are prepended with the process ID and an optional IP address, and entries
|
||||
# written to the log file are timestamped.
|
||||
#
|
||||
# @param ip The IP address to log with the message. Defaults to 'unknown'
|
||||
# @param message The message to write to the log
|
||||
sub warn_log {
|
||||
my $ip = shift || "unknown";
|
||||
my $message = shift;
|
||||
|
||||
print $logfile scalar(localtime)," [$$:$ip]: $message\n"
|
||||
if($logfile);
|
||||
|
||||
warn "[$$:$ip]: $message\n";
|
||||
}
|
||||
|
||||
|
||||
## @fn void die_log($ip, $message)
|
||||
# Write an error message a log file if it is opened, and then die. Errors
|
||||
# are prepended with the process ID and an optional IP address, and entries
|
||||
# written to the log file are timestamped.
|
||||
#
|
||||
# @param ip The IP address to log with the message. Defaults to 'unknown'
|
||||
# @param message The message to write to the log
|
||||
sub die_log {
|
||||
my $ip = shift || "unknown";
|
||||
my $message = shift;
|
||||
|
||||
print $logfile scalar(localtime)," [$$:$ip]: $message\n"
|
||||
if($logfile);
|
||||
|
||||
die "[$$:$ip]: $message\n";
|
||||
}
|
||||
|
||||
|
||||
## @fn void start_log($filename, $progname)
|
||||
# Start logging warnings and errors to a file. If logging is already enabled,
|
||||
# this will close the currently open log before opening the new one. The log
|
||||
# file is appended to rather than truncated.
|
||||
#
|
||||
# @param filename The name of the file to log to.
|
||||
# @param progname A optional program name to show in the log. Defaults to $0
|
||||
sub start_log {
|
||||
my $filename = shift;
|
||||
my $progname = shift || $0;
|
||||
|
||||
# Close the logfile if it has been opened already
|
||||
end_log($progname) if($logfile);
|
||||
|
||||
# Open in append mode
|
||||
open($logfile, ">> $filename")
|
||||
or die "Unable to open log file $filename: $!";
|
||||
|
||||
my $tm = scalar localtime;
|
||||
print $logfile "\n----------= Starting $progname [pid: $$] at $tm =----------\n";
|
||||
$logtime = time();
|
||||
}
|
||||
|
||||
|
||||
## @fn void end_log($progname)
|
||||
# Stop logging warnings and errors to a file. This will write an indicator
|
||||
# that logging is stopping to the file and then close it.
|
||||
#
|
||||
# @param progname A optional program name to show in the log. Defaults to $0
|
||||
sub end_log {
|
||||
my $progname = shift || $0;
|
||||
|
||||
if($logfile) {
|
||||
my $tm = scalar localtime;
|
||||
my $elapsed = time() - $logtime;
|
||||
|
||||
print $logfile "----------= Completed $progname [pid: $$] at $tm, execution time $elapsed seconds =----------\n";
|
||||
close($logfile);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
280
Modules.pm
Normal file
280
Modules.pm
Normal file
@ -0,0 +1,280 @@
|
||||
## @file
|
||||
# This file contains the implementation of the Module loading class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 0.1
|
||||
# @date 14 Feb 2009
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class
|
||||
# A class to simplify runtime loading of plugin modules. This class provides
|
||||
# methods to allow the various block plugin modules to be loaded on demand
|
||||
# during script execution.
|
||||
package Modules;
|
||||
|
||||
#use lib qw(/home/webperl); # modules needed for utils, blocks needed for plugins
|
||||
use DBI;
|
||||
use Logging qw(die_log);
|
||||
use strict;
|
||||
|
||||
use vars qw{$VERSION $errstr};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = 0.1;
|
||||
$errstr = '';
|
||||
}
|
||||
|
||||
# ==============================================================================
|
||||
# Creation
|
||||
|
||||
## @cmethod $ new(%args)
|
||||
# Create a new Modules object. This will create an object that provides functions
|
||||
# to create block modules on the fly.
|
||||
# cgi - The CGI object to access parameters and cookies through.
|
||||
# dbh - The database handle to use for queries.
|
||||
# phpbb - An object through which to talk to a phpBB3 database
|
||||
# settings - The system settings object
|
||||
# template - The system template object
|
||||
# session - The session object
|
||||
# blockdir - The directory containing blocks.
|
||||
# @param args A hash of key, value pairs to initialise the object with.
|
||||
# @return A new Modules object, or undef if a problem occured.
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
my $self = {
|
||||
cgi => undef,
|
||||
dbh => undef,
|
||||
phpbb => undef,
|
||||
settings => undef,
|
||||
template => undef,
|
||||
session => undef,
|
||||
blockdir => undef,
|
||||
@_,
|
||||
};
|
||||
|
||||
# If we get here and still don't have a database connection, we need to fall over
|
||||
return set_error("No database connection available.") if(!$self -> {"dbh"});
|
||||
|
||||
# Check we also have a cgi object to play with
|
||||
return set_error("No CGI object available.") if(!$self -> {"cgi"});
|
||||
|
||||
# Aaand settings....
|
||||
return set_error("No settings object available.") if(!$self -> {"settings"});
|
||||
|
||||
# ... finally, template
|
||||
return set_error("No settings template available.") if(!$self -> {"template"});
|
||||
|
||||
# update @INC if needed
|
||||
unshift(@INC, $self -> {"blockdir"}) if($self -> {"blockdir"});
|
||||
|
||||
my $obj = bless $self, $class;
|
||||
|
||||
# Set the template object's module reference
|
||||
$obj -> {"template"} -> set_module_obj($obj);
|
||||
|
||||
# and we're done
|
||||
return $obj
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Loading support
|
||||
#
|
||||
|
||||
## @method $ new_module_byblockid($blockid)
|
||||
# Given a block id, create an instance of the module that implements that block. This
|
||||
# will look in the blocks table to obtain the module id that implements the block, and
|
||||
# then create an instance of that module.
|
||||
#
|
||||
# @param blockid The id of the block to generate an instance for.
|
||||
# @return An instance of the module, or undef on error.
|
||||
sub new_module_byblockid {
|
||||
my $self = shift;
|
||||
my $blockid = shift;
|
||||
|
||||
my $sth = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"settings"} -> {"database"} -> {"blocks"}."
|
||||
WHERE id = ?");
|
||||
$sth -> execute($blockid) or
|
||||
die_log($self -> {"cgi"} -> remote_host(), "new_module_byblockid: Unable to execute query: ". $self -> {"dbh"} -> errstr);
|
||||
|
||||
my $modrow = $sth -> fetchrow_hashref();
|
||||
|
||||
# If we have a block row, return an instance of the module for it
|
||||
return $self -> new_module_byid($modrow -> {"module_id"},
|
||||
$modrow -> {"args"})
|
||||
if($modrow);
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
## @method $ new_module_byname($modname, $argument)
|
||||
# Load a module based on its name, checking against the database to obtain the real
|
||||
# module name, and whether the module is active. Returns a new object of the module
|
||||
# on success, undef if the module is disabled or if there's a problem.
|
||||
#
|
||||
# @param modname The name of the module to load.
|
||||
# @param argument Argument to pass to the module constructor.
|
||||
# @return An instance of the module, or undef on error.
|
||||
sub new_module_byname {
|
||||
my $self = shift;
|
||||
my $modname = shift;
|
||||
my $argument = shift;
|
||||
|
||||
return $self -> _new_module_internal("WHERE name LIKE ?",
|
||||
$modname,
|
||||
$argument);
|
||||
}
|
||||
|
||||
|
||||
## @method $ new_module_byid($modid, $argument)
|
||||
# Load a module based on its id, checking against the database to obtain the real
|
||||
# module name, and whether the module is active. Returns a new object of the module
|
||||
# on success, undef if the module is disabled or if there's a problem.
|
||||
#
|
||||
# @param modid The id of the module to load.
|
||||
# @param argument Argument to pass to the module constructor.
|
||||
# @return An instance of the module, or undef on error.
|
||||
sub new_module_byid {
|
||||
my $self = shift;
|
||||
my $modid = shift;
|
||||
my $argument = shift;
|
||||
|
||||
return $self -> _new_module_internal("WHERE module_id = ?",
|
||||
$modid,
|
||||
$argument);
|
||||
}
|
||||
|
||||
|
||||
## @method $ _new_module_internal($where, $argument, $modargs)
|
||||
# Create an instance of a module. This uses the where and argument parameters as part of a database
|
||||
# query to determine what the actual name of the module is, and then load and instantiate it.
|
||||
#
|
||||
# @param where The WHERE clause to add to the module select query.
|
||||
# @param argument The argument for the select query.
|
||||
# @param modargs The argument to pass to the module.
|
||||
# @return A new object, or undef if a problem occured or the module is disabled.
|
||||
sub _new_module_internal {
|
||||
my $self = shift;
|
||||
my $where = shift;
|
||||
my $argument = shift;
|
||||
my $modarg = shift;
|
||||
|
||||
my $modh = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"settings"} -> {"database"} -> {"modules"}." $where");
|
||||
$modh -> execute($argument)
|
||||
or die_log($self -> {"cgi"} -> remote_host(), "Unable to execute module resolve query: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
my $modrow = $modh -> fetchrow_hashref();
|
||||
|
||||
# bomb if the mofule record is not found, or the module is inactive
|
||||
return set_error("Unable to locate module $argument using $where, or module is inactive.") if(!$modrow || !$modrow -> {"active"});
|
||||
|
||||
my $name = $modrow -> {"perl_module"};
|
||||
no strict "refs"; # must disable strict references to allow named module loading.
|
||||
require "$name.pm";
|
||||
my $modobj = $name -> new($modrow -> {"id"},
|
||||
$modarg,
|
||||
$self -> {"cgi"},
|
||||
$self -> {"dbh"},
|
||||
$self -> {"phpbb"},
|
||||
$self -> {"template"},
|
||||
$self -> {"settings"},
|
||||
$self -> {"session"},
|
||||
$self)
|
||||
or set_error("Unable to load module: ".$Block::errstr);
|
||||
use strict;
|
||||
|
||||
return $modobj;
|
||||
}
|
||||
|
||||
|
||||
## @method $ build_sidebar($side, $page)
|
||||
# Generate the contents of a sidebar. This will load the modules listed as appearing on the specified
|
||||
# side of the page, and call on their block_display() functions, concatenating the results into one
|
||||
# large string.
|
||||
#
|
||||
# @param side The side to generate the blocks for. Must be 'left' or 'right'.
|
||||
# @param page An optional page ID (corresponding to the module currently shown on in the core of the
|
||||
# page) that can be used to filter the blocks shown in the sidebar.
|
||||
# @return A string containing the sidebar HTML, or undef if there was an error.
|
||||
sub build_sidebar {
|
||||
my $self = shift;
|
||||
my $side = shift;
|
||||
my $page = shift || 0;
|
||||
|
||||
# Bomb with an error is side is not valid
|
||||
return set_error("build_sidebar called with an illegal value for side: $side")
|
||||
unless($side eq "left" || $side eq "right");
|
||||
|
||||
# If a page is specified, we need to filter on it, or zero. OTherwise we'll be filtering on just 0
|
||||
my $filter = $page ? "(filter = ? OR filter = 0)" : "filter = ?";
|
||||
|
||||
# Pull out blocks that match the specified side type, filtering them so that only 'always show' or blocks
|
||||
# that show on the current page are shown.
|
||||
my $sth = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"settings"} -> {"database"} -> {"blocks"}."
|
||||
WHERE TYPE = ? AND $filter
|
||||
ORDER BY position");
|
||||
$sth -> execute($side, $page) or
|
||||
die_log($self -> {"cgi"} -> remote_host(), "build_sidebar: Unable to execute query: ". $self -> {"dbh"} -> errstr);
|
||||
|
||||
my $result = "";
|
||||
while(my $row = $sth -> fetchrow_hashref()) {
|
||||
# Load the block module
|
||||
my $headerobj = $self -> new_module_byid($row -> {"module_id"},
|
||||
$row -> {"args"});
|
||||
|
||||
# If we have an object, ask it do generate its block display.
|
||||
$result .= $headerobj -> block_display() if($headerobj);
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Block identification support
|
||||
|
||||
## @method $ get_block_id($blockname)
|
||||
# Obtain the id of a block given its unique name. This will, hopefully, allow templates
|
||||
# to include references to modules without hard-coding IDs (ironically, hard coding
|
||||
# the module names seems so much less nasty... weird...)
|
||||
#
|
||||
# @param blockname The name of the block to obtain the id for.
|
||||
# @return The block id, or undef if the name can not be located.
|
||||
sub get_block_id {
|
||||
my $self = shift;
|
||||
my $blockname = shift;
|
||||
|
||||
my $blockh = $self -> {"dbh"} -> prepare("SELECT id FROM ".$self -> {"settings"} -> {"database"} -> {"blocks"}."
|
||||
WHERE name LIKE ?");
|
||||
$blockh -> execute($blockname)
|
||||
or die_log($self -> {"cgi"} -> remote_host(), "get_block_id: Unable to execute query: ". $self -> {"dbh"} -> errstr);
|
||||
|
||||
# Do we have the block?
|
||||
my $blockr = $blockh -> fetchrow_arrayref();
|
||||
|
||||
# If we have the block id return it, otherwise return undef.
|
||||
return $blockr -> [0] if($blockr);
|
||||
return undef;
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# Error functions
|
||||
|
||||
sub set_error { $errstr = shift; return undef; }
|
||||
|
||||
1;
|
||||
581
SessionHandler.pm
Normal file
581
SessionHandler.pm
Normal file
@ -0,0 +1,581 @@
|
||||
## @file
|
||||
# This file contains the implementation of the perl phpBB3 interaction class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 0.5
|
||||
# @date 23 Sep 2009
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class
|
||||
# The SessionHandler class provides cookie-based session facilities for
|
||||
# maintaining user state over http transactions. This code depends on
|
||||
# integration with a phpBB3 database: a number of custom tables are needed
|
||||
# (see config docs), but user handling is tied to phpBB3 user tables, and
|
||||
# a number of joins between custom tables and phpBB3 ones require the two
|
||||
# to share database space. This code provides session verification, and
|
||||
# takes some steps towards ensuring security against cookie hijacking, but
|
||||
# as with any cookie based auth system there is the potential for security
|
||||
# issues.
|
||||
#
|
||||
# This code is heavily based around the session code used by phpBB3, with
|
||||
# features removed or added to fit the different requirements of the ORB,
|
||||
# starforge site, etc
|
||||
package SessionHandler;
|
||||
|
||||
require 5.005;
|
||||
use strict;
|
||||
|
||||
# Standard module imports
|
||||
use DBI;
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
use Compress::Bzip2;
|
||||
use MIME::Base64;
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
# Custom module imports
|
||||
use phpBB3;
|
||||
use Logging qw(die_log);
|
||||
|
||||
# Globals...
|
||||
use vars qw{$VERSION $errstr};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = 0.2;
|
||||
$errstr = '';
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# Constructor
|
||||
|
||||
## @cmethod SessionHandler new(@args)
|
||||
# Create a new SessionHandler object, and start session handling.
|
||||
#
|
||||
# @param args A hash of key, value pairs to initialise the object with.
|
||||
# @return A reference to a new SessionHandler object.
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
my $self = {
|
||||
cgi => undef,
|
||||
dbh => undef,
|
||||
phpbb => undef,
|
||||
template => undef,
|
||||
settings => undef,
|
||||
@_,
|
||||
};
|
||||
|
||||
# Ensure that we have objects that we need
|
||||
return set_error("cgi object not set") unless($self -> {"cgi"});
|
||||
return set_error("dbh object not set") unless($self -> {"dbh"});
|
||||
return set_error("phpbb object not set") unless($self -> {"phpbb"});
|
||||
return set_error("template object not set") unless($self -> {"template"});
|
||||
return set_error("settings object not set") unless($self -> {"settings"});
|
||||
|
||||
# Bless class so we canuse it properly
|
||||
$self = bless $self, $class;
|
||||
|
||||
# cleanup if necessary
|
||||
return undef
|
||||
unless($self -> session_cleanup());
|
||||
|
||||
# Determine the name of the cookie, and fall over if it isn't available for some reason
|
||||
my $cookiebase = $self -> {"settings"} -> {"config"} -> {"cookie_name"}
|
||||
or return set_error("Unable to determine sessioncookie name");
|
||||
|
||||
# Now try to obtain a session id - start by looking at the cookies
|
||||
$self -> {"sessid"} = $self -> {"cgi"} -> cookie($cookiebase."_sid"); # The session id cookie itself
|
||||
$self -> {"sessuser"} = $self -> {"cgi"} -> cookie($cookiebase."_u"); # Which user does this session claim to be for?
|
||||
$self -> {"autokey"} = $self -> {"cgi"} -> cookie($cookiebase."_k"); # Do we have an autologin key for the user?
|
||||
|
||||
# If we don't have a session id now, try to pull it from the query string
|
||||
$self -> {"sessid"} = $self -> {"cgi"} -> param("sid") if(!$self -> {"sessid"});
|
||||
|
||||
# If we have a session id, we need to check it
|
||||
if($self -> {"sessid"}) {
|
||||
# Try to get the session...
|
||||
my $session = $self -> get_session($self -> {"sessid"});
|
||||
|
||||
$self -> {"session_time"} = $session -> {"session_time"};
|
||||
|
||||
# Do we have a valid session?
|
||||
if($session) {
|
||||
# Is the user accessing the site from the same(-ish) IP address?
|
||||
if($self -> ip_check($ENV{"REMOTE_ADDR"}, $session -> {"session_ip"})) {
|
||||
# Has the session expired?
|
||||
if(!$self -> session_expired($session)) {
|
||||
# The session is valid, and can be touched.
|
||||
$self -> touch_session($session);
|
||||
|
||||
return $self;
|
||||
} # if(!$self -> session_expired($session)) {
|
||||
} # if($self -> ip_check($ENV{"REMOTE_ADDR"}, $session -> {"session_ip"})) {
|
||||
} # if($session) {
|
||||
} # if($sessid) {
|
||||
|
||||
# Get here, and we don't have a session at all, so make one.
|
||||
return $self -> create_session();
|
||||
}
|
||||
|
||||
|
||||
## @method $ create_session($user, $persist)
|
||||
# Create a new session. If the user is not specified, this creates an anonymous session,
|
||||
# otherwise the session is attached to the user.
|
||||
#
|
||||
# @param user Optional user ID to associate with the session.
|
||||
# @param persist If true, and autologins are permitted, an autologin key is generated for
|
||||
# this session.
|
||||
# @return true if the session was created, undef otherwise.
|
||||
sub create_session {
|
||||
my $self = shift;
|
||||
my $user = shift;
|
||||
my $persist = shift;
|
||||
my $userdata;
|
||||
|
||||
# nuke the cookies, it's the only way to be sure
|
||||
delete($self -> {"cookies"}) if($self -> {"cookies"});
|
||||
|
||||
# get the current time...
|
||||
my $now = time();
|
||||
|
||||
# If persistent logins are not permitted, disable them
|
||||
$self -> {"autokey"} = $persist = '' if(!$self -> {"phpbb"} -> get_config("allow_autologin"));
|
||||
|
||||
# Set a default last visit, might be updated later
|
||||
$self -> {"last_visit"} = $now;
|
||||
|
||||
# If we have a key, and a user in the cookies, try to get it
|
||||
if($self -> {"autokey"} && $self -> {"sessuser"} && $self -> {"sessuser"} != $phpBB3::ANONYMOUS) {
|
||||
my $autocheck = $self -> {"dbh"} -> prepare("SELECT u.* FROM ".
|
||||
$self -> {"phpbb"} -> {"prefix"}."users AS u, ".
|
||||
$self -> {"settings"} -> {"database"} -> {"keys"}." AS k
|
||||
WHERE u.user_id = ?
|
||||
AND u.user_type IN (0, 3)
|
||||
AND k.user_id = u.user_id
|
||||
AND k.key_id = ?");
|
||||
$autocheck -> execute($self -> {"sessuser"}, md5_hex($self -> {"autokey"}))
|
||||
or return set_error("Unable to peform user lookup query\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
$userdata = $autocheck -> fetchrow_hashref;
|
||||
|
||||
# If we don't have a key and user in the cookies, do we have a user specified?
|
||||
} elsif($user) {
|
||||
$self -> {"autokey"} = '';
|
||||
$self -> {"sessuser"} = $user;
|
||||
|
||||
my $userh = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"phpbb"} -> {"prefix"}."users
|
||||
WHERE user_id = ?
|
||||
AND user_type IN (0, 3)");
|
||||
$userh -> execute($self -> {"sessuser"})
|
||||
or return set_error("Unable to peform user lookup query\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
$userdata = $userh -> fetchrow_hashref;
|
||||
}
|
||||
|
||||
# If we don't have any user data then either the key didn't match in the database,
|
||||
# the user doesn't exist, is inactive, or is a bot. Just get the anonymous user
|
||||
if(!$userdata) {
|
||||
$self -> {"autokey"} = '';
|
||||
$self -> {"sessuser"} = $phpBB3::ANONYMOUS;
|
||||
|
||||
my $userh = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"phpbb"} -> {"prefix"}."users
|
||||
WHERE user_id = ?");
|
||||
$userh -> execute($self -> {"sessuser"})
|
||||
or return set_error("Unable to peform user lookup query\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
$userdata = $userh -> fetchrow_hashref;
|
||||
|
||||
# If we have user data, we also want their last login time if possible
|
||||
} elsif($self -> {"settings"} -> {"detabase"} -> {"lastvisit"}) {
|
||||
my $visith = $self -> {"dbh"} -> prepare("SELECT last_visit FROM ".$self -> {"settings"} -> {"detabase"} -> {"lastvisit"}.
|
||||
" WHERE user_id = ?");
|
||||
$visith -> execute($userdata -> {"user_id"})
|
||||
or return set_error("Unable to peform last visit lookup query\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
my $visitr = $visith -> fetchrow_arrayref;
|
||||
|
||||
# Fall back on now if we have no last visit time
|
||||
$self -> {"last_visit"} = $visitr -> [0] if($visitr);
|
||||
}
|
||||
|
||||
# Determine whether the session can be made persistent (requires the user to be registered, and normal)
|
||||
my $is_registered = ($userdata -> {"user_id"} && $userdata -> {"user_id"} != $phpBB3::ANONYMOUS && ($userdata -> {"user_type"} == 0 || $userdata -> {"user_type"} == 3));
|
||||
$persist = (($self -> {"autokey"} || $persist) && $is_registered) ? 1 : 0;
|
||||
|
||||
# Do we already have a session id? If we do, and it's an anonymous session, we want to nuke it
|
||||
if($self -> {"sessid"}) {
|
||||
my $killsess = $self -> {"dbh"} -> prepare("DELETE FROM ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" WHERE session_id = ? AND session_user_id = ?");
|
||||
$killsess -> execute($self -> {"sessid"}, $phpBB3::ANONYMOUS)
|
||||
or return set_error("Unable to remove anonymous session\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
|
||||
# generate a new session id. The md5 of a unique ID should be unique enough...
|
||||
$self -> {"sessid"} = md5_hex($self -> {"phpbb"} -> unique_id());
|
||||
|
||||
# store the time
|
||||
$self -> {"session_time"} = $now;
|
||||
|
||||
# create a new session
|
||||
my $sessh = $self -> {"dbh"} -> prepare("INSERT INTO ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" VALUES(?, ?, ?, ?, ?, ?)");
|
||||
$sessh -> execute($self -> {"sessid"},
|
||||
$self -> {"sessuser"},
|
||||
$now,
|
||||
$now,
|
||||
$ENV{"REMOTE_ADDR"},
|
||||
$persist)
|
||||
or return set_error("Unable to peform session creation\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
$self -> set_login_key($self -> {"sessuser"}, $ENV{"REMOTE_ADDR"}) if($persist);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
## @method $ delete_session()
|
||||
# Delete the current session, resetting the user's data to anonymous. This will
|
||||
# remove the user's current session, and any associated autologin key, and then
|
||||
# generate a new anonymous session for the user.
|
||||
sub delete_session {
|
||||
my $self = shift;
|
||||
|
||||
# Okay, the important part first - nuke the session
|
||||
my $nukesess = $self -> {"dbh"} -> prepare("DELETE FROM ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" WHERE session_id = ? AND session_user_id = ?");
|
||||
$nukesess -> execute($self -> {"sessid"}, $self -> {"sessuser"})
|
||||
or return set_error("Unable to remove session\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
# If we're not dealing with anonymous, we need to store the visit time,
|
||||
# and nuke any autologin key for the now defunct session
|
||||
if($self -> {"sessuser"} != $phpBB3::ANONYMOUS) {
|
||||
|
||||
# If we don't have a session time for some reason, make it now
|
||||
$self -> {"session_time"} = time() if(!$self -> {"session_time"});
|
||||
|
||||
# set this user's last visit time to the session time if possible
|
||||
if($self -> {"settings"} -> {"database"} -> {"lastvisit"}) {
|
||||
my $newtime = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"lastvisit"}.
|
||||
" SET last_visit = ?
|
||||
WHERE user_id = ?");
|
||||
$newtime -> execute($self -> {"session_time"}, $self -> {"sessuser"})
|
||||
or return set_error("Unable to update last visit time\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
|
||||
# And now remove any session keys
|
||||
if($self -> {"autokey"}) {
|
||||
my $nukekeys = $self -> {"dbh"} -> prepare("DELETE FROM ".$self -> {"settings"} -> {"database"} -> {"keys"}.
|
||||
" WHERE key_id = ? AND user_id = ?");
|
||||
$nukekeys -> execute(md5_hex($self -> {"autokey"}), $self -> {"sessuser"})
|
||||
or return set_error("Unable to remove session key\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
}
|
||||
|
||||
# clear all the session settings internally for safety
|
||||
$self -> {"sessuser"} = $self -> {"sessid"} = $self -> {"autokey"} = $self -> {"session_time"} = undef;
|
||||
|
||||
# And create a new anonymous session (note that create_session should handle deleting the cookie cache!)
|
||||
return $self -> create_session();
|
||||
}
|
||||
|
||||
|
||||
## @method $ encode_querystring($query, $nofix)
|
||||
# Encode the query string so that it is safe to include it in a hidden input field
|
||||
# in the login form.
|
||||
#
|
||||
# @param query The querystring to encode
|
||||
# @param nofix If true, this disables the fix needed to make CGI::query_string()'s output usable.
|
||||
# @return The safely encoded querystring.
|
||||
sub encode_querystring {
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $nofix = shift;
|
||||
|
||||
$query =~ s/;/&/g unless($nofix); # fix query_string() return... GRRRRRRR...
|
||||
|
||||
return encode_base64($query, '');
|
||||
}
|
||||
|
||||
|
||||
## @method $ decode_querystring($query)
|
||||
# Converts the encoded query string back to standard query string form.
|
||||
#
|
||||
# @param query The encoded querystring to decode
|
||||
# @return The decoded version of the querystring.
|
||||
sub decode_querystring {
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
|
||||
# Bomb if we don't have a query, or it is not valid base64
|
||||
return "" if(!$query || $query =~ m{[^A-Za-z0-9+/=]});
|
||||
|
||||
return decode_base64($query);
|
||||
}
|
||||
|
||||
|
||||
## @method $ session_cookies()
|
||||
# Obtain a reference to an array containing the session cookies.
|
||||
#
|
||||
# @return A reference to an array of session cookies.
|
||||
sub session_cookies {
|
||||
my $self = shift;
|
||||
|
||||
# Cache the cookies if needed, calls to create_session should ensure the cache is
|
||||
# removed before any changes are made... but this shouldn't really be called before
|
||||
# create_session in reality anyway.
|
||||
if(!$self -> {"cookies"}) {
|
||||
my $expires = "+".($self -> {"phpbb"} -> get_config("max_autologin_time") || 365)."d";
|
||||
my $sesscookie = $self -> create_cookie($self -> {"settings"} -> {"config"} -> {"cookie_name"}.'_sid', $self -> {"sessid"}, $expires);
|
||||
my $sessuser = $self -> create_cookie($self -> {"settings"} -> {"config"} -> {"cookie_name"}.'_u', $self -> {"sessuser"}, $expires);
|
||||
my $sesskey;
|
||||
if($self -> {"sessuser"} != $phpBB3::ANONYMOUS) {
|
||||
if($self -> {"autokey"}) {
|
||||
$sesskey = $self -> create_cookie($self -> {"settings"} -> {"config"} -> {"cookie_name"}.'_k', $self -> {"autokey"}, $expires);
|
||||
}
|
||||
} else {
|
||||
$sesskey = $self -> create_cookie($self -> {"settings"} -> {"config"} -> {"cookie_name"}.'_k', '', '-1y');
|
||||
}
|
||||
|
||||
$self -> {"cookies"} = [ $sesscookie, $sessuser, $sesskey ];
|
||||
}
|
||||
|
||||
return $self -> {"cookies"};
|
||||
}
|
||||
|
||||
|
||||
# ==============================================================================
|
||||
# Theoretically internal stuff
|
||||
|
||||
|
||||
## @method ip_check($userip, $sessip)
|
||||
# Checks whether the specified IPs match. The degree of match required depends
|
||||
# on the ip_check setting in the SessionHandler object this is called on: 0 means
|
||||
# that no checking is done, number between 1 and 4 indicate sections of the
|
||||
# dotted decimal IPs are checked (1 = 127., 2 = 127.0, 3 = 127.0.0., etc)
|
||||
#
|
||||
# @param userip The IP the user is connecting from.
|
||||
# @param sessip The IP associated with the session.
|
||||
# @return True if the IPs match, false if they do not.
|
||||
sub ip_check {
|
||||
my $self = shift;
|
||||
my $userip = shift;
|
||||
my $sessip = shift;
|
||||
|
||||
# How may IP address segments should be compared?
|
||||
my $iplen = $self -> {"phpbb"} -> get_config('ip_check');
|
||||
|
||||
# bomb immediately if we aren't checking IPs
|
||||
return 1 if($iplen == 0);
|
||||
|
||||
# pull out as much IP as we're interested in
|
||||
my ($usercheck) = $userip =~ /((?:\d+.?){$iplen})/;
|
||||
my ($sesscheck) = $sessip =~ /((?:\d+.?){$iplen})/;
|
||||
|
||||
# Do the IPs match?
|
||||
return $usercheck eq $sesscheck;
|
||||
}
|
||||
|
||||
|
||||
## @method $ session_cleanup()
|
||||
# Run garbage collection over the sessions table. This will remove all expired
|
||||
# sessions and session keys, but in the process it may need to update user
|
||||
# last visit information.
|
||||
#
|
||||
# @return true oin successful cleanup (or cleanup not needed), false on error.
|
||||
sub session_cleanup {
|
||||
my $self = shift;
|
||||
|
||||
my $now = time();
|
||||
my $timelimit = $now - $self -> {"phpbb"} -> get_config("session_length");
|
||||
|
||||
# We only want to run the garbage collect occasionally
|
||||
if($self -> {"settings"} -> {"config"} -> {"lastgc"} < $now - $self -> {"phpbb"} -> get_config("session_gc")) {
|
||||
# Okay, we're due a garbage collect, update the config to reflect that we're doing it
|
||||
$self -> {"settings"} -> set_db_config($self -> {"dbh"}, $self -> {"settings"} -> {"database"} -> {"settings"}, "lastgc", $now);
|
||||
|
||||
# Remove expired guest sessions first
|
||||
my $nukesess = $self -> {"dbh"} -> prepare("DELETE FROM ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" WHERE session_user_id = ?
|
||||
AND session_time < ?");
|
||||
$nukesess -> execute($phpBB3::ANONYMOUS, $timelimit)
|
||||
or return set_error("Unable to remove expired guest sessions\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
# now get the most recent expired sessions for each user
|
||||
my $lastsess = $self -> {"dbh"} -> prepare("SELECT session_user_id,MAX(session_time) FROM ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" WHERE session_time < ?
|
||||
GROUP BY session_user_id");
|
||||
$lastsess -> execute($timelimit)
|
||||
or return set_error("Unable to obtain expired session list\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
# Prepare an update query so we don't remake it each time through the loop...
|
||||
my $updatelast;
|
||||
if($self -> {"settings"} -> {"database"} -> {"lastvisit"}) {
|
||||
$updatelast = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"lastvisit"}.
|
||||
" SET last_visit = ?
|
||||
WHERE user_id = ?");
|
||||
}
|
||||
|
||||
# Go through each returned user updating their last visit to the session time
|
||||
while(my $lastrow = $lastsess -> fetchrow_arrayref()) {
|
||||
# set the user's last visit if needed
|
||||
if($self -> {"settings"} -> {"database"} -> {"lastvisit"}) {
|
||||
$updatelast -> execute($lastrow -> [1], $lastrow -> [0])
|
||||
or return set_error("Unable to update last visit for user ".$lastrow -> [0]."\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
|
||||
# and then nuke any expired sessions
|
||||
$nukesess -> execute($lastrow -> [0], $timelimit)
|
||||
or return set_error("Unable to remove expired sessions for user ".$lastrow -> [0]."\nError was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
## @method $ session_expired($sessdata)
|
||||
# Determine whether the specified session has expired. Returns true if it has,
|
||||
# false if it is still valid.
|
||||
#
|
||||
# @param $sessdata A reference to a hash containing the session information
|
||||
# @return true if the session has expired, false otherwise
|
||||
sub session_expired {
|
||||
my $self = shift;
|
||||
my $sessdata = shift;
|
||||
|
||||
# If the session is not an autologin session, and the last update was before the session length, it is expired
|
||||
if(!$sessdata -> {"session_autologin"}) {
|
||||
return 1 if($sessdata -> {"session_time"} < time() - ($self -> {"phpbb"} -> get_config("session_length") + 60));
|
||||
|
||||
} else {
|
||||
my $max_autologin = $self -> {"phpbb"} -> get_config("max_autologin_time");
|
||||
|
||||
# If the session is autologin, and it is older than the max autologin time, or autologin is not enabled, it's expired
|
||||
return 1 if(!$self -> {"phpbb"} -> get_config("allow_autologin") ||
|
||||
($max_autologin && $sessdata -> {"session_time"} < time() - ((86400 * $max_autologin) + 60)));
|
||||
}
|
||||
|
||||
# otherwise, the session is valid
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
## @method $ get_session($sessid)
|
||||
# Obtain the data for the session with the specified session ID. If there is no
|
||||
# session with the specified id in the database, this returns undef, otherwise it
|
||||
# returns a reference to a hash containing the session data.
|
||||
#
|
||||
# @param sessid The ID of the session to search for.
|
||||
# @return A reference to a hash containing the session data, or undef on error.
|
||||
sub get_session {
|
||||
my $self = shift;
|
||||
my $sessid = shift;
|
||||
|
||||
my $sessh = $self -> {"dbh"} -> prepare("SELECT * FROM ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" WHERE session_id = ?");
|
||||
$sessh -> execute($sessid)
|
||||
or return set_error("Unable to peform session lookup query - ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
return $sessh -> fetchrow_hashref();
|
||||
}
|
||||
|
||||
|
||||
## @method void touch_session($session)
|
||||
# Touch the specified session, updating its timestamp to the current time. This
|
||||
# will only touch the session if it has not been touched in the last minute,
|
||||
# otherwise this function does nothing.
|
||||
#
|
||||
# @param session A reference to a hash containing the session data.
|
||||
sub touch_session {
|
||||
my $self = shift;
|
||||
my $session = shift;
|
||||
|
||||
if(time() - $session -> {"session_time"} > 60) {
|
||||
$self -> {"session_time"} = time();
|
||||
|
||||
my $finger = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"sessions"}.
|
||||
" SET session_time = ?
|
||||
WHERE session_id = ?");
|
||||
$finger -> execute($self -> {"session_time"}, $session -> {"session_id"})
|
||||
or die_log($self -> {"cgi"} -> remote_host(), "Unable to touch session. Error was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## @method void set_login_key()
|
||||
# Create the auto login key for the current session user.
|
||||
#
|
||||
sub set_login_key {
|
||||
my $self = shift;
|
||||
|
||||
my $key = $self -> {"autokey"};
|
||||
my $key_id = $self -> {"phpbb"} -> unique_id(substr($self -> {"sessid"}, 0, 8));
|
||||
|
||||
# If we don't have a key, we want to create a new key in the table
|
||||
if(!$key) {
|
||||
my $keyh = $self -> {"dbh"} -> prepare("INSERT INTO ".$self -> {"settings"} -> {"database"} -> {"keys"}.
|
||||
" VALUES(?, ?, ?, ?)");
|
||||
$keyh -> execute(md5_hex($key_id), $self -> {"sessuser"}, $ENV{REMOTE_ADDR}, time())
|
||||
or die_log($self -> {"cgi"} -> remote_host(), "Unable to create autologin key. Error was: ".$self -> {"dbh"} -> errstr);
|
||||
|
||||
# If we have a key, we want to overwrite it with the new stuff
|
||||
} else {
|
||||
my $keyh = $self -> {"dbh"} -> prepare("UPDATE ".$self -> {"settings"} -> {"database"} -> {"keys"}.
|
||||
" SET key_id = ?, last_ip = ?, last_login = ? WHERE user_id = ? AND key_id = ?");
|
||||
$keyh -> execute(md5_hex($key_id), $ENV{REMOTE_ADDR}, 0 + time(), 0 + $self -> {"sessuser"}, md5_hex($key))
|
||||
or die_log($self -> {"cgi"} -> remote_host(), "Unable to update autologin key. Error was: ".$self -> {"dbh"} -> errstr);
|
||||
}
|
||||
|
||||
$self -> {"autokey"} = $key_id;
|
||||
}
|
||||
|
||||
|
||||
## @method $ create_cookie($name, $value, $expires)
|
||||
# Creates a cookie that can be sent back to the user's browser to provide session
|
||||
# information.
|
||||
#
|
||||
# @param name The name of the cookie to set
|
||||
# @param value The value to set for the cookie
|
||||
# @param expires An optional expiration value
|
||||
# @return A cookie suitable to send to the browser.
|
||||
sub create_cookie {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
my $expires = shift;
|
||||
|
||||
return $self -> {"cgi"} -> cookie(-name => $name,
|
||||
-value => $value,
|
||||
-expires => $expires,
|
||||
-path => $self -> {"settings"} -> {"config"} -> {"cookie_path"},
|
||||
-domain => $self -> {"settings"} -> {"config"} -> {"cookie_domain"},
|
||||
-secure => $self -> {"settings"} -> {"config"} -> {"cookie_secure"});
|
||||
}
|
||||
|
||||
|
||||
## @fn $ set_error($error)
|
||||
# Set the error string to the specified value. This updates the class error
|
||||
# string and returns undef.
|
||||
#
|
||||
# @param error The message to set in the error string
|
||||
# @return undef, always.
|
||||
sub set_error {
|
||||
$errstr = shift;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
609
Template.pm
Normal file
609
Template.pm
Normal file
@ -0,0 +1,609 @@
|
||||
## @file
|
||||
# This file contains the implementation of the template engine.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 1.0
|
||||
# @date 23 November 09
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class Template
|
||||
# A simple Template class with internationalisation support. Note that
|
||||
# this class does not cache templates or any fancy stuff like that - it
|
||||
# just provides a simple interface to generate content based on
|
||||
# replacing markers in files.
|
||||
package Template;
|
||||
|
||||
use Logging;
|
||||
use POSIX qw(strftime);
|
||||
use Utils qw(path_join superchomp);
|
||||
use strict;
|
||||
|
||||
our ($VERSION, $errstr, $utfentities, $entities);
|
||||
|
||||
BEGIN {
|
||||
$VERSION = 1.0;
|
||||
$errstr = '';
|
||||
|
||||
$utfentities = { '\xC2\xA3' => '£',
|
||||
'\xE2\x80\x98' => '‘',
|
||||
'\xE2\x80\x99' => '’',
|
||||
'\xE2\x80\x9C' => '“',
|
||||
'\xE2\x80\x9D' => '”',
|
||||
'\xE2\x80\x93' => '–',
|
||||
'\xE2\x80\x94' => '—',
|
||||
'\xE2\x80\xA6' => '…',
|
||||
};
|
||||
$entities = {'\x91' => '‘', # 0x91 (145) and 0x92 (146) are 'smart' singlequotes
|
||||
'\x92' => '’',
|
||||
'\x93' => '“', # 0x93 (147) and 0x94 (148) are 'smart' quotes
|
||||
'\x94' => '”',
|
||||
'\x96' => '–', # 0x96 (150) and 0x97 (151) are en and emdashes
|
||||
'\x97' => '—',
|
||||
'\x88' => '…', # 0x88 (133) is an ellisis
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Constructor and language loading
|
||||
|
||||
## @cmethod $ new(%args)
|
||||
# Create a new Template object. This will create a new Template object that will
|
||||
# allow templates to be loaded into strings, or printed to stdout. Meaningful
|
||||
# arguments to this constructor are:
|
||||
# basedir - The directory containing template themes. Defaults to "templates".
|
||||
# langdir - The directory containing language files. Defaults to "lang".
|
||||
# lang - The language file to use. Defaults to "en"
|
||||
# theme - The theme to use. Defaults to "default"
|
||||
# timefmt - The time format string, strftime(3) format. Defaults to "%a, %d %b %Y %H:%M:%S"
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
|
||||
# Object constructors don't get much more minimal than this...
|
||||
my $self = { "basedir" => "templates",
|
||||
"langdir" => "lang",
|
||||
"lang" => "en",
|
||||
"theme" => "default",
|
||||
"timefmt" => '%a, %d %b %Y %H:%M:%S',
|
||||
"mailfmt" => '%a, %d %b %Y %H:%M:%S %z',
|
||||
"mailcmd" => '/usr/sbin/sendmail -t -f chris@starforge.co.uk',#pevesupport@cs.man.ac.uk', # Change -f as needed!
|
||||
@_,
|
||||
};
|
||||
|
||||
my $obj = bless $self, $class;
|
||||
|
||||
# Load the language definitions
|
||||
$obj -> load_language() or return undef;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
|
||||
## @method void DESTROY()
|
||||
# Destructor method to prevent a circular list formed from a reference to the modules
|
||||
# hash from derailing normal destruction.
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
|
||||
$self -> {"modules"} = undef;
|
||||
}
|
||||
|
||||
|
||||
## @method void set_module_obj($modules)
|
||||
# Store a reference to the module handler object so that the template loader can
|
||||
# do block name replacements.
|
||||
#
|
||||
# @param modules A reference to the system module handler object.
|
||||
sub set_module_obj {
|
||||
my $self = shift;
|
||||
|
||||
$self -> {"modules"} = shift;
|
||||
}
|
||||
|
||||
|
||||
## @method $ load_language(void)
|
||||
# Load all of the language files in the appropriate language directory into a hash.
|
||||
# This will attempt to load all .lang files inside the langdir/lang/ directory,
|
||||
# attempting to parse VARNAME = string into a hash using VARNAME as the key and string
|
||||
# as the value. The hash is build up inside the Template object rather than returned.
|
||||
#
|
||||
# @return true if the language files loaded correctly, undef otherwise.
|
||||
sub load_language {
|
||||
my $self = shift;
|
||||
|
||||
# First work out which directory we are dealing with
|
||||
my $langdir = path_join($self -> {"langdir"}, $self -> {"lang"});
|
||||
|
||||
# open it, so we can process files therein
|
||||
opendir(LANG, $langdir)
|
||||
or return set_error("Unable to open language directory '$langdir' for reading: $!");
|
||||
|
||||
while(my $name = readdir(LANG)) {
|
||||
# Skip anything that doesn't identify itself as a .lang file
|
||||
next unless($name =~ /\.lang$/);
|
||||
|
||||
my $filename = path_join($langdir, $name);
|
||||
|
||||
# Attempt to open and parse the lang file
|
||||
if(open(WORDFILE, "<:utf8", $filename)) {
|
||||
while(my $line = <WORDFILE>) {
|
||||
superchomp($line);
|
||||
|
||||
# skip comments
|
||||
next if($line =~ /^\s*#/);
|
||||
|
||||
# Pull out the key and value, and
|
||||
my ($key, $value) = $line =~ /^\s*(\w+)\s*=\s*(.*)$/;
|
||||
next unless(defined($key) && defined($value));
|
||||
|
||||
# Unslash any \"s
|
||||
$value =~ s/\\\"/\"/go;
|
||||
|
||||
# warn if we are about to redefine a word
|
||||
warn_log("Unknown", "$key already exists in language hash!") if($self -> {"words"} -> {$key});
|
||||
|
||||
$self -> {"words"} -> {$key} = $value;
|
||||
}
|
||||
|
||||
close(WORDFILE);
|
||||
} else {
|
||||
warn_log("Unknown", "Unable to open language file $filename: $!");
|
||||
}
|
||||
}
|
||||
|
||||
closedir(LANG);
|
||||
|
||||
# Did we get any language data at all?
|
||||
return set_error("Unable to load any lanugage data. Check your language selection!")
|
||||
if(!defined($self -> {"words"}));
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Templating functions
|
||||
|
||||
## @method $ replace_langvar($varname, $default, $varhash)
|
||||
# Replace the specified language variable with the appropriate text string. This
|
||||
# takes a language variable name and returns the value stored for that variable,
|
||||
# if there is on. If there is no value available, and the default is provided,
|
||||
# that is returned. If all else fails this just returns "<$varname>"
|
||||
#
|
||||
# @param varname The name of the language variable to obtain a value for.
|
||||
# @param default An optional default value.
|
||||
# @param varhash An optional reference to a hash containing key-value pairs, any
|
||||
# occurance of the key in the text string is replaced with the value.
|
||||
# @return The value for the language variable, or the default if the value is not
|
||||
# available. If the default is not available either this returns the
|
||||
# variable name in angled brackets.
|
||||
sub replace_langvar {
|
||||
my $self = shift;
|
||||
my $varname = shift;
|
||||
my $default = shift;
|
||||
my $varhash = shift;
|
||||
|
||||
# Fix up the arguments - if default is a reference, then it's really the varhash
|
||||
# and default was omitted
|
||||
if(ref($default) eq "HASH") {
|
||||
$varhash = $default;
|
||||
|
||||
# Make the default value be the variable name in red to hilight problems
|
||||
$default = "<span style=\"color: red\">$varname</span>";
|
||||
}
|
||||
|
||||
# strip the leadin L_ if present
|
||||
$varname =~ s/^L_//o;
|
||||
|
||||
if(defined($self -> {"words"} -> {$varname})) {
|
||||
my $txtstr = $self -> {"words"} -> {$varname};
|
||||
|
||||
# If we have a hash of variables to substitute, do the substitute
|
||||
if($varhash) {
|
||||
foreach my $key (keys(%$varhash)) {
|
||||
my $value = defined($varhash -> {$key}) ? $varhash -> {$key} : ""; # make sure we get no undefined problems...
|
||||
$txtstr =~ s/\Q$key\E/$value/g;
|
||||
}
|
||||
}
|
||||
|
||||
# Do any module marker replacements if we can
|
||||
if($self -> {"modules"}) {
|
||||
$txtstr =~ s/{B_\[(\w+?)\]}/$self->replace_blockname($1)/ge;
|
||||
}
|
||||
|
||||
return $txtstr;
|
||||
}
|
||||
|
||||
return $default;
|
||||
}
|
||||
|
||||
|
||||
## @method $ replace_blockname($blkname, $default)
|
||||
# Replace a block name with the internal ID for the block. This will replace
|
||||
# a block name with the equivalent block ID and it can cope with the name
|
||||
# being embedded in B_[...] strings.
|
||||
#
|
||||
# @param blkname The name of the block to replace with a block id.
|
||||
# @param default Optional default id to use if the block is not found.
|
||||
# @return The id that corresponds to the specified block name.
|
||||
sub replace_blockname {
|
||||
my $self = shift;
|
||||
my $blkname = shift;
|
||||
my $default = shift || "0";
|
||||
|
||||
# Strip the B_[ ] if present
|
||||
$blkname =~ s/^B_\[(.*)\]$/$1/;
|
||||
|
||||
my $modid = $self -> {"modules"} -> get_block_id($blkname);
|
||||
|
||||
return defined($modid) ? $modid : $default;
|
||||
}
|
||||
|
||||
|
||||
## @method $ load_template($name, $varmap)
|
||||
# Load a template from a file and replace the tags in it with the values given
|
||||
# in a hashref, return the string containing the filled-in template. The first
|
||||
# argument should be the filename of the template, the second should be the
|
||||
# hashref containing the key-value pairs. The keys should be the tags in the
|
||||
# template to replace, the values should be the text to replace those keys
|
||||
# with. Tags can be any format and may contain regexp reserved chracters.
|
||||
#
|
||||
# @param name The name of the template to load.
|
||||
# @param varmap A reference to a hash containing values to replace in the template.
|
||||
# @return The template with replaced variables and language markers.
|
||||
sub load_template {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $varmap = shift;
|
||||
|
||||
my $filename = path_join($self -> {"basedir"}, $self -> {"theme"}, $name);
|
||||
|
||||
if(open(TEMPLATE, "<:utf8", $filename)) {
|
||||
undef $/;
|
||||
my $lines = <TEMPLATE>;
|
||||
$/ = "\n";
|
||||
close(TEMPLATE);
|
||||
|
||||
# Do variable substitution
|
||||
$self -> process_template(\$lines, $varmap);
|
||||
|
||||
return $lines;
|
||||
} else {
|
||||
return "<span class=\"error\">load_template: error opening $filename: $!</span>";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## @method $ process_template($text, $varmap)
|
||||
# Perform variable substitution on the text. This will go through each key in the
|
||||
# provided hashref and replace all occurances of the key in the text with the value
|
||||
# set in the hash for that key.
|
||||
#
|
||||
# @param text The text to process. If this is a reference, the replacement is
|
||||
# done in-place, otherwise the modified string is returned.
|
||||
# @param varmap A reference to a hash containing variable names as keys, and the
|
||||
# values to substitute for the keys.
|
||||
# @return undef if text was a reference, otherwise a copy of the modified string.
|
||||
sub process_template {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my $varmap = shift;
|
||||
|
||||
# If text is a reference already, we can just use it. Otherwise we need
|
||||
# to make a reference to the text to simplify the code in the loop below.
|
||||
my $textref = ref($text) ? $text : \$text;
|
||||
|
||||
# replace all the keys in the text with the appropriate value.
|
||||
my ($key, $value);
|
||||
foreach $key (keys %$varmap) {
|
||||
# pull out the value if it is defined, blank otherwise - avoids "Use of uninitialized value in substitution" problems
|
||||
$value = defined($varmap -> {$key}) ? $varmap -> {$key} : "";
|
||||
$$textref =~ s/\Q$key\E/$value/g;
|
||||
}
|
||||
|
||||
# Do any language marker replacements
|
||||
$$textref =~ s/{L_(\w+?)}/$self->replace_langvar($1)/ge;
|
||||
|
||||
# Do any module marker replacements if we can
|
||||
if($self -> {"modules"}) {
|
||||
$$textref =~ s/{B_\[(\w+?)\]}/$self->replace_blockname($1)/ge;
|
||||
}
|
||||
|
||||
# Convert some common utf-8 characters
|
||||
foreach my $char (keys(%$utfentities)) {
|
||||
$$textref =~ s/$char/$utfentities->{$char}/g;
|
||||
}
|
||||
|
||||
# Convert horrible smart quote crap from windows
|
||||
foreach my $char (keys(%$entities)) {
|
||||
$$textref =~ s/$char/$entities->{$char}/g;
|
||||
}
|
||||
|
||||
# Return nothing if the text was a reference to begin with, otherwise
|
||||
# return the text itself.
|
||||
return ref($text) ? undef : $text;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Higher-level templating functions
|
||||
|
||||
## @method $ message_box($title, $type, $summary, $longdesc, $additional)
|
||||
# Create a message box block to include in a page. This generates a templated
|
||||
# message box to include in a page. It assumes the presence of messagebox.tem
|
||||
# in the template directory, containing markers for a title, type, summary,
|
||||
# long description and additional data. The type argument should correspond
|
||||
# to an image in the {template}/images/messages/ directory without an extension.
|
||||
#
|
||||
# @param title The title of the message box.
|
||||
# @param type The message type.
|
||||
# @param summary A summary version of the message.
|
||||
# @param longdesc The full message body
|
||||
# @param additional Any additional content to include in the message box.
|
||||
# @return A string containing the message box.
|
||||
sub message_box {
|
||||
my ($self, $title, $type, $summary, $longdesc, $additional) = @_;
|
||||
|
||||
return $self -> load_template("messagebox.tem", { "***title***" => $title,
|
||||
"***icon***" => $type,
|
||||
"***summary***" => $summary,
|
||||
"***longdesc***" => $longdesc,
|
||||
"***additional***" => $additional });
|
||||
}
|
||||
|
||||
|
||||
## @method $ wizard_box($title, $type, $stages, $stage, $longdesc, $additional)
|
||||
# Create a wizard box block to include in a page. This generates a templated
|
||||
# wizard box to include in a page. It assumes the presence of wizardbox.tem
|
||||
# in the template directory, containing markers for a title, type, path,
|
||||
# long description and additional data. The type argument should correspond
|
||||
# to an image in the {template}/images/messages/ directory without an extension.
|
||||
#
|
||||
# @param title The title of the message box.
|
||||
# @param type The message type.
|
||||
# @param stages A reference to an array of hashes containing stages in the wizard.
|
||||
# @param stage The current stage number.
|
||||
# @param longdesc The message body to show below the stages.
|
||||
# @param additional Any additional content to include in the wizard box (forms, etc)
|
||||
# @return A string containing the wizard box.
|
||||
sub wizard_box {
|
||||
my ($self, $title, $type, $stages, $stage, $longdesc, $additional) = @_;
|
||||
|
||||
# Preload the step template
|
||||
my $steptem = $self -> load_template("wizardstep.tem");
|
||||
chomp($steptem);
|
||||
|
||||
my $path = "";
|
||||
for(my $s = 0; $s < scalar(@$stages); ++$s) {
|
||||
# calculate some gubbins to make life easier...
|
||||
my $step = $stages -> [$s];
|
||||
my $mode;
|
||||
|
||||
if($s < $stage) {
|
||||
$mode = "passed";
|
||||
} elsif($s > $stage) {
|
||||
$mode = "inactive";
|
||||
} else {
|
||||
$mode = "active";
|
||||
}
|
||||
|
||||
# Now we need to generate the stage image, this should be simple...
|
||||
$path .= $self -> process_template($steptem, {"***image***" => $step -> {$mode},
|
||||
"***width***" => $step -> {"width"},
|
||||
"***height***" => $step -> {"height"},
|
||||
"***alt***" => $step -> {"alt"}});
|
||||
}
|
||||
|
||||
return $self -> load_template("wizardbox.tem", { "***title***" => $title,
|
||||
"***icon***" => $type,
|
||||
"***path***" => $path,
|
||||
"***longdesc***" => $longdesc,
|
||||
"***additional***" => $additional });
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Emailing functions
|
||||
|
||||
|
||||
## @method $ email_template($template, $args)
|
||||
# Load a template and send it as an email to the recipient(s) listed in the arguments.
|
||||
# This function will load a template from the template directory, fill in the fields
|
||||
# as normal, and prepend an email header using the to and cc fields in the args (bcc
|
||||
# is not supported).
|
||||
#
|
||||
# @param template The name of the template to load and send.
|
||||
# @param args A reference to a hash containing values to substitute in the template.
|
||||
# This MUST include 'from', 'to', and 'subject' values!
|
||||
# @return undef on success, otherwise an error message.
|
||||
sub email_template {
|
||||
my $self = shift;
|
||||
my $template = shift;
|
||||
my $args = shift;
|
||||
my $email;
|
||||
|
||||
# Check we have required fields
|
||||
return "No from field specified in email template arguments." if(!$args -> {"***from***"});
|
||||
return "No to field specified in email template arguments." if(!$args -> {"***to***"});
|
||||
return "No subject field specified in email template arguments." if(!$args -> {"***subject***"});
|
||||
|
||||
# Build the header first...
|
||||
$email = "From: ".$args -> {"***from***"}."\n";
|
||||
$email .= "To: ".$args -> {"***to***"}."\n";
|
||||
$email .= "Cc: ".$args -> {"***cc***"}."\n" if($args -> {"***cc***"});
|
||||
$email .= "Subject: ".$args -> {"***subject***"}."\n";
|
||||
$email .= "Date: ".strftime($args -> {"***date***"})."\n" if($args -> {"***date***"});
|
||||
$email .= "\n";
|
||||
|
||||
# now load and process the template
|
||||
$email .= $self -> load_template($template, $args);
|
||||
|
||||
# And send the email
|
||||
return $self -> send_email_sendmail($email);
|
||||
}
|
||||
|
||||
|
||||
## @method $ send_email_sendmail($email)
|
||||
# Send the specified email using sendmail. This will print the contents of the
|
||||
# specified email over a pipe to sendmail, sending it to the recipient(s). The
|
||||
# email should be complete, including any headers.
|
||||
#
|
||||
# @param email The email to send.
|
||||
# @return undef if the mail was sent, otherwise an error message is returned.
|
||||
sub send_email_sendmail {
|
||||
my $self = shift;
|
||||
my $email = shift;
|
||||
|
||||
open(SENDMAIL, "|".$self -> {"mailcmd"})
|
||||
or return "send_email_sendmail: unable to open sendmail pipe: $!";
|
||||
print SENDMAIL $email
|
||||
or return "send_email_sendmail: error while printing email: $!";
|
||||
close(SENDMAIL);
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Support functions
|
||||
|
||||
## @method $ get_bbcode_path(void)
|
||||
# Obtain the path to the current template's bbcode translation file. If the path
|
||||
# does not exist, this returns undef, otherwise it provides the path containing
|
||||
# the bbcode translations.
|
||||
#
|
||||
# @return The filename of the bbcode translation file, or undef if it does not exist.
|
||||
sub get_bbcode_path {
|
||||
my $self = shift;
|
||||
|
||||
my $filename = path_join($self -> {"basedir"}, $self -> {"theme"});
|
||||
|
||||
return (-d $filename) ? $filename : undef;
|
||||
}
|
||||
|
||||
|
||||
## @method $ format_time($time)
|
||||
# Given a time un unix timestamp format (seconds since the epoc), create a formatted
|
||||
# date string.
|
||||
#
|
||||
# @param $time The time to format.
|
||||
# @return The string containing the formatted time.
|
||||
sub format_time {
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
|
||||
return strftime($self -> {"timefmt"}, localtime($time));
|
||||
}
|
||||
|
||||
|
||||
## @method $ html_clean($text)
|
||||
# Process the specified text, converting ampersands, quotes, and angled brakets
|
||||
# into xml-safe character entity codes.
|
||||
#
|
||||
# @param text The text to process.
|
||||
# @return The text with &, ", < and > replaces with &, $quot;, $lt;, and >
|
||||
sub html_clean {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
|
||||
# replace the four common character entities (FIXME: support more entities)
|
||||
if($text) {
|
||||
$text =~ s/&(?!amp|quot|lt|gt)/&/g; # only replace & if it isn't already prefixing a character entity we know
|
||||
$text =~ s/\"/"/g;
|
||||
$text =~ s/\</</g;
|
||||
$text =~ s/\>/>/g;
|
||||
}
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
|
||||
## @method $ bytes_to_human($bytes, $long)
|
||||
# Produce a human-readable version of the provided byte count. If $bytes is
|
||||
# less than 1024 the string returned is in bytes. Between 1024 and 1048576 is
|
||||
# in KB, between 1048576 and 1073741824 is in MB, over 1073741824 is in GB
|
||||
#
|
||||
# @param bytes The byte count to convert
|
||||
# @param long If set to true, use 'Bytes' instead of B in the output. Defaults to false.
|
||||
# @return A string containing a human-readable version of the byte count.
|
||||
sub bytes_to_human {
|
||||
my $self = shift;
|
||||
my $bytes = shift;
|
||||
my $long = shift;
|
||||
|
||||
my $ext = $long ? "ytes" : "";
|
||||
|
||||
if($bytes >= 1073741824) {
|
||||
return sprintf("%.2f GB$ext", $bytes / 1073741824);
|
||||
} elsif($bytes >= 1048576) {
|
||||
return sprintf("%.2f MB$ext", $bytes / 1048576);
|
||||
} elsif($bytes >= 1024) {
|
||||
return sprintf("%.2f KB$ext", $bytes / 1024);
|
||||
} else {
|
||||
return "$bytes B$ext";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## @fn $ humanise_seconds($seconds)
|
||||
# Convert a number of seconds to days/hours/minutes/seconds. This will take
|
||||
# the specified number of seconds and output a string containing the number
|
||||
# of days, hours, minutes, and seconds it corresponds to.
|
||||
#
|
||||
# @param seconds The number of seconds to convert.
|
||||
# @return A string containing the seconds in a human readable form
|
||||
sub humanise_seconds {
|
||||
my $self = shift;
|
||||
my $seconds = shift;
|
||||
my ($frac, $mins, $hours, $days);
|
||||
my $result = "";
|
||||
|
||||
($frac) = $seconds =~ /\.(\d+)$/;
|
||||
$days = int($seconds / (24 * 60 * 60));
|
||||
$hours = ($seconds / (60 * 60)) % 24;
|
||||
$mins = ($seconds / 60) % 60;
|
||||
$seconds = $seconds % 60;
|
||||
|
||||
if($days) {
|
||||
$result .= $days." day".($days > 1 ? "s" : "");
|
||||
}
|
||||
|
||||
if($hours) {
|
||||
$result .= ", " if($result);
|
||||
$result .= $hours." hour".($hours > 1 ? "s" : "");
|
||||
}
|
||||
|
||||
if($mins) {
|
||||
$result .= ", " if($result);
|
||||
$result .= $mins." minute".($mins > 1 ? "s" : "");
|
||||
}
|
||||
|
||||
if($seconds) {
|
||||
$result .= ", " if($result);
|
||||
$result .= $seconds.($frac ? ".$frac" : "")." seconds".($mins > 1 ? "s" : "");
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Error functions
|
||||
|
||||
sub set_error { $errstr = shift; return undef; }
|
||||
|
||||
1;
|
||||
201
Utils.pm
Normal file
201
Utils.pm
Normal file
@ -0,0 +1,201 @@
|
||||
## @file
|
||||
# System-wide utility functions. The functions in this file may be useful at
|
||||
# any point throughout the system, so they are collected here to prevent the
|
||||
# need for multiple copies around various modules.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
# @version 1.0
|
||||
# @date 1 March 09
|
||||
# @copy 2009, Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program 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 3 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.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @mainpage
|
||||
#
|
||||
# @section Introduction
|
||||
#
|
||||
# The perl modules described here are the support modules used widely
|
||||
# throughout my web applications. They are generally used in a very specific
|
||||
# framework, but they provide features that may be useful in a standalone
|
||||
# environment.
|
||||
#
|
||||
# @todo The documentation for the modules is still a work in progress: some
|
||||
# areas need to be fleshed out substantially, and the addition of
|
||||
# examples or test cases would be very helpful.
|
||||
|
||||
## @class
|
||||
# System-wide utility functions. The functions in this file may be useful at
|
||||
# any point throughout the system, so they are collected here to prevent the
|
||||
# need for multiple copies around various modules.
|
||||
package Utils;
|
||||
require Exporter;
|
||||
use POSIX qw(strftime);
|
||||
use strict;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw();
|
||||
our @EXPORT_OK = qw(path_join superchomp is_defined_numeric rfc822_date title_case sentence_case get_proc_size);
|
||||
|
||||
our $VERSION = 1.0;
|
||||
|
||||
|
||||
## @fn $ path_join(@fragments)
|
||||
# Take an array of path fragments and concatenate them together. This will
|
||||
# concatenate the list of path fragments provided using '/' as the path
|
||||
# delimiter (this is not as platform specific as might be imagined: windows
|
||||
# will accept / delimited paths). The resuling string is trimmed so that it
|
||||
# <b>does not</b> end in /, but nothing is done to ensure that the string
|
||||
# returned actually contains a valid path.
|
||||
#
|
||||
# @param fragments The path fragments to join together.
|
||||
# @return A string containing the path fragments joined with forward slashes.
|
||||
sub path_join {
|
||||
my @fragments = @_;
|
||||
|
||||
my $result = "";
|
||||
|
||||
# We can't easily use join here, as fragments might end in /, which
|
||||
# would result in some '//' in the string. This may be slower, but
|
||||
# it will ensure there aren't stray slashes around.
|
||||
foreach my $fragment (@fragments) {
|
||||
$result .= $fragment;
|
||||
# append a slash if the result doesn't end with one
|
||||
$result .= "/" if($result !~ /\/$/);
|
||||
}
|
||||
|
||||
# strip the trailing / if there is one
|
||||
return substr($result, 0, length($result) - 1) if($result =~ /\/$/);
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
## @fn void superchomp($line)
|
||||
# Remove any white space or newlines from the end of the specified line. This
|
||||
# performs a similar task to chomp(), except that it will remove <i>any</i> OS
|
||||
# newline from the line (unix, dos, or mac newlines) regardless of the OS it
|
||||
# is running on. It does not remove unicode newlines (U0085, U2028, U2029 etc)
|
||||
# because they are made of spiders.
|
||||
#
|
||||
# @param line A reference to the line to remove any newline from.
|
||||
sub superchomp(\$) {
|
||||
my $line = shift;
|
||||
|
||||
$$line =~ s/(?:[\s\x{0d}\x{0a}\x{0c}]+)$//o;
|
||||
}
|
||||
|
||||
|
||||
## @fn $ is_defined_numeric($cgi, $param)
|
||||
# Determine whether the specified cgi parameter is purely numeric and return it
|
||||
# if it is. If the named parameter is not entirely numeric, this returns undef.
|
||||
#
|
||||
# @param cgi The cgi handle to check the parameter through.
|
||||
# @param param The name of the cgi parameter to check.
|
||||
# @return The numeric value in the parameter, or undef if it is not purely numeric.
|
||||
sub is_defined_numeric {
|
||||
my ($cgi, $param) = @_;
|
||||
|
||||
if(defined($cgi -> param($param)) && $cgi -> param($param) !~ /\D/) {
|
||||
return $cgi -> param($param);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
## @fn $ rfc822_date($timestamp)
|
||||
# Convert a unix timestamp into a rfc822-formatted date string. This is guaranteed
|
||||
# to generate a RFC822 date string (unlike strftime, which could generate week and
|
||||
# month names in another language in other locales)
|
||||
#
|
||||
# @param timestamp The unix timestamp to convert to rfc822 format
|
||||
# @return The rfc822 time string
|
||||
sub rfc822_date {
|
||||
my $timestamp = shift;
|
||||
|
||||
# set up constants we'll need
|
||||
my @days = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
|
||||
my @mons = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
|
||||
|
||||
my @ts = localtime($timestamp);
|
||||
|
||||
return sprintf("%s, %02d %s %4d %02d:%02d:%02d %s",
|
||||
$days[$ts[6]], $ts[3], $mons[$ts[4]], $ts[5] + 1900,
|
||||
$ts[2], $ts[1], $ts[0],
|
||||
strftime("%Z", @ts));
|
||||
}
|
||||
|
||||
|
||||
## @fn void title_case($strref, $punc_border)
|
||||
# Convert the words in the provided string to titlecase. This will process all the
|
||||
# words in the string referred to by the argument into titlecase, to avoid situations
|
||||
# where allcaps/alllower input has been provided for a string that does not look
|
||||
# good that way.
|
||||
#
|
||||
# @param strref A reference to the string to convert.
|
||||
# @param punc_border If true, punctuation is treated as boundary character, otherwise
|
||||
# only the start or end of the string or space is treated as a
|
||||
# word boundary.
|
||||
sub title_case(\$$) {
|
||||
my $strref = shift;
|
||||
my $punc_border = shift;
|
||||
|
||||
if($punc_border) {
|
||||
$$strref =~ s/\b(.*?)\b/ucfirst(lc($1))/ge;
|
||||
} else {
|
||||
$$strref =~ s/(^|\s)((?:\S|\z)+)/$1.ucfirst(lc($2))/gem;
|
||||
}
|
||||
|
||||
# Fix up entities
|
||||
$$strref =~ s/(&[a-z]+;)/lc($1)/ge;
|
||||
}
|
||||
|
||||
## @fn void sentence_case($strref)
|
||||
# Convert the words in the provided string to sentence case. This will process all the
|
||||
# words in the string referred to by the argument to convert the string to sentence case,
|
||||
# to avoid situations where allcaps/alllower input has been provided for a string that
|
||||
# does not look good that way.
|
||||
#
|
||||
# @param strref A reference to the string to convert.
|
||||
sub sentence_case(\$) {
|
||||
my $strref = shift;
|
||||
|
||||
$$strref = ucfirst(lc($$strref));
|
||||
|
||||
}
|
||||
|
||||
|
||||
## @fn $ get_proc_size()
|
||||
# Determine how much memory the current process is using. This examines the process'
|
||||
# entry in proc, it's not portable, but frankly I don't care less about that.
|
||||
#
|
||||
# @return The process virtual size, in bytes, or -1 if it can not be determined.
|
||||
sub get_proc_size {
|
||||
|
||||
# We don't need no steenking newlines
|
||||
my $nl = $/;
|
||||
undef $/;
|
||||
|
||||
# Try to open and read the process' stat file
|
||||
open(STAT, "/proc/$$/stat")
|
||||
or die "Unable to read stat file for current process ($$)\n";
|
||||
my $stat = <STAT>;
|
||||
close(STAT);
|
||||
|
||||
# Now we need to pull out the vsize field
|
||||
my ($vsize) = $stat =~ /^[-\d]+ \(.*?\) \w+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ [-\d]+ ([-\d]+)/;
|
||||
|
||||
return $vsize || -1;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
x
Reference in New Issue
Block a user