File Coverage

blib/lib/Apache/WeSQL.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package Apache::WeSQL;

use 5.006;
use strict;
use warnings;
use lib(".");
use lib("./WeSQL/");

use POSIX qw(strftime);

use Apache::WeSQL::SqlFunc qw( :all );
use Apache::WeSQL::Journalled qw( :all );
use Apache::WeSQL::Display qw( :all );
use Apache::WeSQL::Auth qw( :all );

use Apache::Constants qw(:common);
require Exporter;

# We have to define $VERSION as follows instead of a simpler 'our $VERSION', because perl 5.005_03
# can not cope with this in MakeMaker (the perl Makefile.PL doesn't execute)
use vars qw($VERSION);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Apache::WeSQL ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
# $dbh $r
our %EXPORT_TAGS = ( 'all' => [ qw(
  %params %cookies redirect error readLayoutFile DEBUG
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

$VERSION = '0.53';

our $DEBUGTYPE = 'apache';

# Preloaded methods go here.

# Some global variables

our ($r);
our ($dbh, %params, %cookies, $errorcode);		#CHECK IF NECESSARY!!
our $DEBUG = 1;

############################################################
# log_error
# Log an error, in different ways depending on the value of $DEBUGTYPE
############################################################
sub log_error {
	my $message = shift;
	if ($DEBUGTYPE eq 'text') {
		print STDERR "$message\n";
	} else {		# Apache style is default!
		my $r = Apache->request;
		$r->log_error($message);
	}
}

############################################################
# display
# Process a WeSQL file
############################################################
sub display {
	$dbh = shift;
	$r = shift;
	my $authsuperuserdir = shift;
	my $cookieheader = shift;
	my @commandlist = @_;

	# These requests are special, and might want to use a HTTP redirect, so we can't
	# print the standard HTTP header just yet! They will have to take care of that
	# themselves.
	my ($result,$errorcode) = ("",0);
	my $uri = $r->uri;

	# Note that the next line will make requests ending in a slash look for a index.wsql file...
	# So if you want to link to a index.html file, you'll have to put the file name in the request!
	$uri .= "index.wsql" if ($uri =~ /\/$/);

	# Multi-language support
	$uri =~ s/\.[\w\-]{2,5}\.wsql$/\.wsql/;

	for ($uri) {
		/\/jadd.wsql$/				&& do { ($result,$errorcode) = &jAddPrepare($dbh,$cookieheader); last; };
		/\/jupdate.wsql$/			&& do { ($result,$errorcode) = &jUpdatePrepare($dbh,$cookieheader); last; };
		/\/jdelete.wsql$/			&& do { ($result,$errorcode) = &jDeletePrepare($dbh,$cookieheader); last; };
		/\/jform.wsql$/				&& do { ($result,$errorcode) = &jForm($dbh,$cookieheader); last; };
		/\/jdeleteform.wsql$/	&& do { ($result,$errorcode) = &jDetails($dbh,$cookieheader); last; };
		/\/jdetails.wsql$/		&& do { ($result,$errorcode) = &jDetails($dbh,$cookieheader); last; };
		/\/jlist.wsql$/				&& do { ($result,$errorcode) = &jList($dbh,0,$cookieheader); last; };
		/\/jloginform.wsql$/	&& do { ($result,$errorcode) = &jLoginForm($dbh,$cookieheader); last; };
		/\/jlogin.wsql$/			&& do { ($result,$errorcode) = &jLogin($dbh,$authsuperuserdir); last; };
		/\/jlogout.wsql$/			&& do { ($result,$errorcode) = &jLogout($dbh); last; };
	}

	if ($result eq "") {
		my $dd = localtime();
		unless ($uri =~ /redirect\.wsql$/) {
			# Print a proper HTTP header
			print <
HTTP/1.1 200 OK
Date: $dd
Server: Apache
EOF
			print "$cookieheader\r\n" if (defined($cookieheader) && ($cookieheader ne ''));
			print <
Connection: close
Content-type: text/html

EOF
		}
		my $doc_root = $r->document_root;

		$result = &readWeSQLFile($doc_root . $uri);
	}

	# Now only parse files as WeSQL if they have a .wsql suffix!! This allows easy mixing of HTML and WeSQL files...
	($result,$errorcode) = &dolayout($result,@commandlist) if ($uri =~ /\.wsql$/);

	if ($errorcode) {
		print "An error has occured: errorcode $errorcode. Please contact the webmaster!!";
	} else {
		print $result;
	}
}

############################################################
# error
# Builds & logs an error message
############################################################
sub error {
	my ($message,$logmessage) = @_;
	&log_error("$$: WeSQL.pm: $logmessage");
  my $dd = localtime();
	return <<"EOF";

Error

Error
$message

This page was dynamically generated by WeSQL $VERSION


EOF
}

########################################################
sub readWeSQLFile {
  my ($layoutfile) = shift;
  unless (defined(open(LAYOUTFILE,$layoutfile))) {
		print &error("File not found.","$$: WeSQL.pm: dolayout: file '$layoutfile' not found!");
		exit;
	}
  my $body = join("",);
  close(LAYOUTFILE);
	my @stat = stat($layoutfile);
	$ENV{FILE_SIZE} = $stat[7];
	$ENV{FILE_LAST_MODIFIED} = $stat[9];
	return ($body);
}

sub dolayout {
	my $body = shift;
  my $errorcode = 0;
	my (@commandlist) = @_;
  foreach (@commandlist) {
		&log_error("$$: WeSQL.pm: dolayout: executing $_") if ($DEBUG > 1);
		$body = eval($_);
		# The following will log errors from the eval()
		&log_error("$$: WeSQL.pm: dolayout: eval error: " . $@) if $@;
  };
  return ($body,$errorcode);
}

############################################################
# dolist, printlist & printlist_inline deal with the
# ...  tag
############################################################

sub dolist {
	my $body = shift;
	my $dbh = shift;
	$body =~ s/(.*?)/&printlist($dbh,$1,$2,$3,$4)/sieg;
	return $body;
}

sub printlist {
  my $dbh = shift;
  my $returnval = "";
  my $prefix = shift;
  $prefix .= "_" if ($prefix ne "");

	my $query = shift;
	my $layout = shift;
	my $nomatchtext = shift;

  my $c = sqlSelectMany($dbh,$query);

	my %data;
	my $colnameref = $c->{NAME_uc};
	foreach (@{$colnameref}) {
		$data{$_} = "";
	}

  if (defined($c) && ($query =~ /^(SELECT|SHOW|DESC)/i)) {
		# Non-select queries will result in a defined $c, but cause a typical
		# "fetch() without execute()' warning in the logs, hence the checking for
		# SELECT, SHOW and DESC above!
    while(my $data=$c->fetchrow_hashref()) { #This is a bit less efficient than fetchrow_arrayref...
      foreach(sort keys %{$data}) { #Make column-names case-insensitive
         $data->{lc($_)} = $data->{$_};
      }
		  my $output = $layout;
      $output =~ s/([^\w]*?)$prefix([A-Z()\[\]0-9\._]*)\|\[(.*?)(?
      $output =~ s/([^\w]*?)$prefix([A-Z()0-9\._]*)/(defined($data->{lc($2)})?"$1$data->{lc($2)}":(exists $data->{lc($2)}?"$1NULL":"$1$prefix$2"))/eg;
      $returnval .= $output;
    }

    if ($returnval eq "") {
       $returnval = "
       $returnval = $nomatchtext unless $nomatchtext eq "";
			# if nomatchtext is the html equivalent of a space, just throw it away:
			# The user doesn't want anything in the html.
       $returnval = "" if $nomatchtext eq " ";
    };
    $c->finish();
    $errorcode = 0;
    #Recursively parse the rest of the file!
    $returnval =~ s/(.*?)/&printlist($dbh,$1,$2,$3,$4)/sieg;
  } elsif (!defined($c)) {
    #upon error ($c is not defined), errorcode will be set to 1, and $returnval will stay empty
    # -> no more recursive invocations of this sub. $errorcode is a global variable (aargh, I know!)
    #that is initialised and checked in dolayout, our caller sub!
		&log_error("$$: c not defined in printlist!");
    $errorcode = 1;
  }

  return $returnval;
}

sub printlist_inline {
  my ($pre, $alt, $value, %data2) = @_;
  $alt =~ s/\\\]/\]/g;
  if (defined($value)) {
    if ($data2{lc($value)} eq "") {
      return "$pre$alt";
    } else {
      return "$pre$value";
    }
  } else {
    if (exists($data2{lc($value)})) {
      return "$pre\LNULL";
    } else {
      return "$pre$alt";
    }
  }
}

############################################################
# end of
# ...  tag code
############################################################

############################################################
# readLayoutFile
# Reads the layout information from the file 'layout.cf'
############################################################
sub readLayoutFile {
	my $file = shift;
	my $nestlevel = shift;

	$nestlevel ||= 0;

	my %aliases;
	my $r = Apache->request;
	# Get the 'base-uri' from the request: for instance, for /admin/jlist.wsql that would be /admin/, and for /jlist.wsql that would just be /
	my $uri = $r->uri;
	my ($baseuri) = ($uri =~ /^(.+)\//);

	my $doc_root = $r->document_root;

	$baseuri .= '/';
	if (!defined(open(LAYOUT,$doc_root . $baseuri . "$file"))) {
		&log_error("$$: WeSQL.pm: readLayoutFile: file '" . $doc_root . $baseuri . "$file' not found!");
		&jErrorMessage("Configuration file not found! Please contact the webmaster.","Can't read $file!",0);
		exit;
	}
	my $layoutinfo = join("",);
	close(LAYOUT);

	if ($layoutinfo =~ /^inherit:(.*?)\n/) {
		if ($nestlevel < 10) {		# Protect people from eternal loops...
			&log_error("$$: WeSQL.pm: readLayoutFile: detected inheritance level " . ++$nestlevel . ", reading $1!");
			%aliases = &readLayoutFile($1,$nestlevel);
		} else {
			&log_error("$$: WeSQL.pm: readLayoutFile: detected 10 levels of inheritance, aborting inheritance here!");
		}
	}

	my @aliases = split(/\n\n/,$layoutinfo);
	foreach (@aliases) {
		my @lines = split(/\n/,$_);
		my $name = "";
		while (($name eq "") && ($#lines > -1)) {
			$name = shift @lines; #First line should contain nothing but the name of the layoutalias
		}
		$aliases{$name} = join("\n",@lines);
	}
	&log_error("$$: WeSQL.pm: readLayoutFile: file '$file' succesfully read") if ($DEBUG);
	return %aliases;
}

############################################################
# dolayouttags deals with the  tag
############################################################

sub dolayouttags {
  my $body = shift;
	my %layout = ();

	if ($cookies{WeSQL_language} ne '') {
		%layout = &readLayoutFile("layout.$cookies{WeSQL_language}.cf");
	} else {
		%layout = &readLayoutFile("layout.cf");
	}

  $body =~ s//&log_error("$$: WeSQL.pm: dolayouttags: no layout key '$1' found") if (!defined($layout{$1}));$layout{$1}||="";$layout{$1}/sieg;
  return $body;
}

############################################################
# end of  tag code
############################################################

############################################################
# dolanguages deals with the text tag
############################################################
sub dolanguages {
	my $body = shift;

	my $uri = $r->uri;
  my ($baseuri) = ($uri =~ /^(.+)\//);
  my $doc_root = $r->document_root;
	$baseuri .= '/';

	opendir(DIR, $doc_root . $baseuri) || die "can't opendir $doc_root . $baseuri: $!";
	my @layoutfiles = grep { /^layout\..*?\.cf$/ && -f $doc_root . "$baseuri/$_" } readdir(DIR);
	closedir DIR;

	# Now deal with the language tags, that could look like stuff or stuff
	foreach (@layoutfiles) {
		my ($lang) = (/^layout\.(.*?)\.cf$/);
  	$body =~ s/<$lang( *\d*|)>(.*?)<\/$lang>/($lang eq $cookies{WeSQL_language})?$2:''/sieg;
	}

	return $body;
}
############################################################
# end of text tag code
############################################################

############################################################
# doinsert & insertfile deal with the  tag
############################################################

sub doinsert {
  my $body = shift;
  $body =~ s//&dosubst(&dosubst(&dosubst(&insertfile($1,$2),"PR_",%params),"ENV_",%ENV),"COOKIE_",%cookies)/sieg;
  return $body;
}

sub insertfile {
  my $prefix = shift;
  my $file = shift;

	# Setting PREFIX in the INCLUDE tag to "" was the old trick to have no prefix
	# Depreciated. Now you can just omit the PREFIX parameter.
  if ($prefix eq "\"\"") { $prefix = ""; }

	# Allow shorthand when no prefix is necessary for the included file:
	#
	if (!defined($file) || ($file eq "")) {
		$file = $prefix;
		$prefix = "";
	}

	unless(defined(open(LFILE,$r->document_root . "/$file"))) {
		&log_error("$$: insertfile: file '$file' not found!");
		return "File not found !";
	}
  my $body = join("",);
  close(LFILE);

  #Now make sure that this inserted file has its separate set of parameters.
  #First make sure that references in perl code get the right values by rewriting the
  #getparams call
  if ($prefix ne "") {
  	$body =~ s/WeSQL\:\:getparams\(\)/WeSQL\:\:getparams\(\$dbh,\"$prefix\"\)/g;
  	#Secondly rewrite all the PR_ references to include the prefix
  	$body =~ s/PR_([A-Z()\[\]0-9\._]*)/PR_$prefix$1/g;
  }
  return $body;
}

############################################################
# end of  tag code
############################################################

############################################################
# dosubst & dosubst_inline deal with the PREFIX style parameters (e.g. PR_PARAM1)
############################################################

sub dosubst {
  my $body = shift;
  my $prefix = shift;
  my %hash = @_;
  my %uchash;
  foreach (keys %hash) {
    $uchash{uc($_)}= $hash{$_};
  };
  #First match occurrences with alternative (after a | character)
	# Example: [PR_WHAT|super] will result in the value of the 'what' parameter if defined,
	# or else in the word 'super'. You can escape ] and | with a backslash.
	$body =~ s/\[(.*?)$prefix([A-Z()\[\]0-9\._]*)(.*?)(?

  #Then match the ones without!
  $body =~ s/([^\w]*)$prefix([A-Z()\[\]0-9\._]*)/(defined($uchash{$2})?"$1$uchash{$2}":"$1$prefix$2")/eg;

  return $body;
}

sub dosubst_inline {
  my ($pre, $value, $post, $alt,%uchash) = @_;
  if (defined($uchash{$value})) {
    $post =~ s/\\\|/\|/g;
    return "$pre$uchash{$value}$post";
  } else {
    $alt =~ s/\\\]/\]/g;
    return "$pre$alt";
  }
}

############################################################
# end of parameter substitution code
############################################################

############################################################
# doeval deals with the  tag
############################################################

# We need evalinline to be able to trap the eval errors...
# $@ gets lost in the s//eval()/ statement in doeval.
sub evalinline {
	my $eval = eval($_[0]);
	&log_error("$$: DOEVAL EVAL ERROR: " . $@) if ($@ || !defined($eval));  #This will log errors from the eval()
	return $eval;
}

sub doeval {
	my $body = shift;
	my $param = shift;
	# First do the single-line style evals (e.g. )
	$body =~ s//&evalinline($1)/emg;
	# And then the multi-line evals
	$body =~ s//&evalinline($1)/esmg;
	return $body;
}

############################################################
# end  tag code
############################################################

############################################################
# docutcheck deals with the  tag
############################################################

sub docutcheck {
	my $body = shift;
#	$body =~ s/(.*?)^\n.*/$1/sm;
	#If you run perl 5.6.0, you will find that the above re is ridiculously slow.
	#This is a Perl bug, fixed in 5.6.1. You can enable the above line if you run
	#Perl 5.6.1.
	$body =~ s/(.*?)^\n.*/$1/sm;
	return $body;
}

############################################################
# end  tag code
############################################################

############################################################
# doparamcheck deals with the  tag
############################################################

# SYNTAX example (new from version 0.50)
#
#
#
# /PARAMCHECK -->

sub doparamcheck {
  my $body = shift;
  $body =~ s//¶mcheck($1)/esmg;
  return $body;
}

sub paramcheck {
  my $body = shift;
	my $headertext = "Below are the problems that have been encountered:
	($headertext) = ($body =~ /(.*?)<\/paramcheckhead>/ism);
  my $footertext = "\n\n";
	($footertext) = ($body =~ /(.*?)<\/paramcheckfoot>/ism);
	$body =~ s/.*?<\/paramcheckhead>\n//ismg;
	$body =~ s/.*?<\/paramcheckfoot>\n//ismg;
	$body =~ s/^\n//smg;	#Remove any empty lines!
  $body =~ s/^(.*?)\s+(\/|!\/)(.*?)(?
	$body = $headertext . $body . "\n" . $footertext if ($body ne '');
  return $body;
}

sub check_one_param {
	my $param = shift;
	my $negation = shift;
	my $regexp = shift;
	my $wrong_string = shift;
	$param = '' if (!defined($param));
	$negation = '' if (!defined($negation));
	$regexp = '' if (!defined($regexp));
	$wrong_string = '' if (!defined($wrong_string));
	chop($negation);
	if ($negation =~ /^!/) {
		if ($regexp eq '') { # !// means that the parameter should be defined
			if (!($param =~ /PR_(.*)/)) { return "$wrong_string\n"; }
		}
		if ($param =~ /$regexp/) {
			return "$wrong_string\n";
		}
	} else { #if parameter is defined, complain if it does not match the condition
		if ($regexp eq '') {
			if ($param =~ /PR_(.*)/) { return "$wrong_string\n"; }
			return "";
		}
		if ((!($param =~ /PR_(.*)/)) && (!($param =~ /$regexp/))) {
			return "$wrong_string\n";
		}
	}
	return "";
}

############################################################
# end  tag code
############################################################

############################################################
# getparams
# Prepare & secure the parameters & cookies passed to us from the user
# These parameters & cookies are available in the rest of the module
# as the global hashes %params and %cookies
############################################################

sub getparams {
	# Sometimes we only want to see a subset of the parameters!
	# (used for the INSERT statement)
	# For this we need a 'prefix' parameter
	my $dbh = shift;
  my $prefix = shift;
	my $cookieheader = shift;
	my $defaultlanguage = shift;
  undef $r if $r;
  undef %params if %params;
  undef %cookies if %cookies;
  $r = Apache->request;
  require CGI;
  my $q = new CGI;

	&log_error("$$: WeSQL.pm: getparams: entering!") if ($DEBUG);

	# Set our %cookies hash
  foreach ($q->cookie) {
    $cookies{$_} = $q->cookie($_);
		$cookies{$_} =~ s/\'/\\\'/sg;
		$cookies{$_} =~ s/\"/\\\"/sg;
		# The NULL character terminates strings in C. Hence all sorts of nasty things can happen when a NULL is passed to a C program like MySQL...
		# The ; character terminates sql statements. Let's nuke that one too.
		$cookies{$_} =~ s/#0|%0|%3B//sg;
		&log_error("$$: WeSQL.pm: getparams: cookie: $_ -> " . $q->cookie($_)) if ($DEBUG);
  }

	# $cookieheader is used to pass values of cookies that have been set while processing this page, and hence
	# are not passed by the browser yet! Used from AppHandler.pm, to pass the session hash when that is first
	# set.
	if (defined($cookieheader) && ($cookieheader ne '')) {
		if ($cookieheader =~ /Set-Cookie: (.*?)=(.*)/) {
			$cookies{$1} = $2;
			&log_error("$$: WeSQL.pm: getparams: cookie: $1 -> $2") if ($DEBUG);
		}
	}

	undef($cookies{su}) if (defined($cookies{su}));   #Nonono, this cookie should NEVER be on your hard-drive :-)
	if (defined($cookies{id}) && defined($cookies{hash})) {		#This is - probably - a logged in user
		# my @sucheck = sqlSelect("superuser","users","uid='$WeSQL::cookies{id}' and status='1'");
  	# Lookup the hash on the users hard-drive. If this hash matches a super-user login, set the su cookie to the id of that superuser
  	# We don't touch the id cookie, thus allowing superusers to 'cloak' as someone else, while maintaining their superuser powers!
  	my @sucheck = sqlSelect($dbh,"select u.superuser,u.id from users as u,logins as l where u.id=l.uid and l.hash='$cookies{hash}' and u.status='1' and l.status='1'");
		if (defined($sucheck[0]) && ($sucheck[0] > 0)) {
   		$cookies{su} = $sucheck[1];
			&log_error("$$: WeSQL.pm: getparams: updated cookie: su -> $cookies{su}") if ($DEBUG);
		}
	}
	# $q->param should not be used beyond this sub, instead use the %params hash that does away
	# with all sorts of dangerous input!
	foreach ($q->param) {
		my $tmp = $_;
		if (defined($prefix) && ($prefix ne '')) {
			next if (!($_ =~ /^$prefix/));
			$tmp =~ s/^$prefix//g;
		}
		# If multiple parameters have the same name, append them together, separated by a pipe symbol
		$params{$tmp} = join("|",$q->param($_));
		# The NULL character terminates strings in C. Hence all sorts of nasty things can happen when a NULL is passed to a C program like MySQL...
		# The ; character terminates sql statements. Let's nuke that one too.
		$params{$tmp} =~ s/#0|%0|%3B//sg;

		#	The following lines are CRUCIAL FOR SECURITY - REMOVE AT YOUR OWN RISK!
		#	Anyone trying to insert a WeSQL-style command (e.g.