File Coverage

blib/lib/DBIx/CGITables.pm

Criterion	Covered	Total	%
statement	18	233	7.7
branch	0	108	0.0
condition	0	67	0.0
subroutine	6	21	28.5
pod	0	15	0.0
total	24	444	5.4

# Copyright (c) Green Smoked Socks Productions y2k

package DBIx::CGITables;

use strict;
use Carp qw(cluck);
use vars qw($VERSION $CGI_Class $Template_Class $Recordset_Class $Client_Error_Class);

$CGI_Class='CGI';
$Template_Class='HTML::Template';
$Recordset_Class='DBIx::Recordset';
$Client_Error_Class='CGI::ClientError';

# Remember to update the POD (yes, even the version number)
# and to tag the cvs (v-major-minor) upon new version numbers
$VERSION="0.001";

# HACKING INFORMATION
# ===================

# The CGITable class is structured like this:

# Special parameters:
#     $self->{filename}, $self->{query}

# Parameters to DBIx::Recordset:
#     $self->{params}->{$recordset_name}->{$param_key} = $param_value

# Output to template:
#     $self->{output}->{$recordset_name}->[$i]->{$db_key} = $db_value
#     $self->{output}->{cgi_query}->[$i] = {key=>$param_key, value=>$param_value}
#     $self->{output}->{$query_key} = $query_value
#     (...and more are likely to come...)

# to avoid inprobable, but still potential name clashes, a dash (-)
# should be prepended to all the recordset names, except the default
# one ('default')

# Recordset objects:
#     $self->{recordsets}->{$recordset_name}

# Parameters to the template class:
#     $self->{T}->{$option_key}->$option_value

# Special recordset variables (PreserveCase, Debug):
#     $self->{RGV}->{$variable_name}->$variable_value

# Changes might occur to the internal data structure, but the API shouldn't.

# Some of the subs below might be splitted if it's needed (i.e. for
# making it easier to alter the class behaviour by inheritance)

sub new {
    # Class identification:
    my $object_or_class = shift; my $class = ref($object_or_class) || $object_or_class;

    # Eventually import params:
    my $self={params=>{default=>($_[0] || {})}};

    # Check for the special !!Query param and/or !!QueryClass and
    # initialize the query:
    if (!($self->{query}=$self->{params}->{default}->{'!!Query'})) {
	$self->{params}->{default}->{'!!QueryClass'}=$CGI_Class
	    unless $self->{params}->{default}->{'!!QueryClass'};
	eval "require ".$self->{params}->{default}->{'!!QueryClass'};
	$self->{query}=$self->{params}->{default}->{'!!QueryClass'}->new;
	return undef if !defined $self->{query};
    }

    # Check for the special !!Filename param:
    $self->{filename}=$self->{params}->{default}->{'!!Filename'} ||
	$ENV{'PATH_TRANSLATED'} ||
	    undef;
    unless ($self->{filename}) {
	print "What template do you want to parse?";
	# Should have used readline ... but at the other hand, this is _not_ the intended usage
	$self->{filename}=<>;
    }
    die "Template not specified"
	unless $self->{filename};

    die "Template ($self->{filename}) not readable or doesn't exist"
	unless -r $self->{filename};

    # Check for !!ParamFileDir and !!ParamFile
    $self->{param_file}=$self->{params}->{default}->{'!!ParamFile'}
        if exists $self->{params}->{default}->{'!!ParamFile'};
    $self->{param_file_dir}=$self->{params}->{default}->{'!!ParamFileDir'}
        if exists $self->{params}->{default}->{'!!ParamFileDir'};

    bless $self, $class;
    return $self;
}

sub search_execute_and_do_everything_even_parse_the_template {
    my $self=shift;
    my $hash=shift;
    $self->fetch_params_from_cookies();
    $self->fetch_params_from_query();
    $self->fetch_params_from_file();
    $self->fetch_params_from_hash($hash)
	if defined($hash);
    $self->execute_recordsets();
    $self->parse_template();
}

sub fetch_params_from_query {
    my $self=shift;
    my $q=$self->{query};
    for my $key ($q->param) {
	my $value=$q->param($key);
	$self->process_param(0, $key, $value);
	push (@{$self->{output}->{cgi_query}}, {key => $key, value => $value});
    }
}

sub fetch_params_from_cookies {
    # It might be relevant to set i.e. !Username and !Password in the cookies.
    # stub!
}

sub fetch_params_from_file {
    my $self=shift;
    my $file=$self->find_param_file() || return 0;
    open(FILE, "<$file");
    while() {
	chop;
	$self->process_param(1, $_);
    }
    close(FILE);
}

sub find_param_file {
    # See the POD for naming conventions

    my $self=shift;
    return $self->{param_file}
        if exists $self->{param_file};
    my $f=$self->{filename};
    $f =~ /\.(\w+)$/
	|| die "The template filename ($f) should have an ending (like .databasetemplate or .end or .dct or whatever)";
    my $pf="$`.param.$1";
    if (my $d=$self->{param_file_dir}) {
	$pf =~ m|/([^/]+)$| || die "given template is a dir?";
	$pf = $d . $1;
    }
    die "Parameter file ($pf) not readable (template filename: $f, param )" unless -r $pf;
    return $pf;
}

sub process_param {
    my $self=shift;
    my $single=shift;
    my $special;
    my $key;
    my $value;
    my $name='default';
    $_=shift;

    /^(;|#|--)/ && return;
    /^(\s*)$/ && return;

    if (/^\%([^\ ]*) /) {
	chop($special=$&);
	$_=$';
    }

    if ($single) {
	if (m#^(.+?)\=#) {
	    $key=$1;
	    $value=$';
	} else {
	    $key=$_;
	    $value=1;
	}
    } else {
	$key=$_;
	$value=shift;
    }

    if ($key =~ m#/(\w+)/#) {
	$name=$1;
	$key=$';
    }

    # Ordinary variable, override or yield and no previous param set.
    if (!$special || ($special =~ /^\%[\=\!]/)
	|| ($special =~ /^\%\?/ && !exists $self->{params}->{$name}->{$key})) {
	# Special key containing '/':
	$self->{output}->{$key}=$value;
	my @keys=split(/\//, $key);
	$self->{params}->{$name}={}
	    unless (exists $self->{params}->{$name});
	my $p=$self->{params}->{$name};
	while (@keys) {
	    $key=shift @keys;
	    if (@keys) {
		if (!exists $p->{$key}) {
		    $p->{$key}={};
		}
		$p=$p->{$key};
	    } else {
		$p->{$key}=$value;
	    }
	}
    }

    # Ignore!
    elsif ($special eq '%()') {
	return;
    }

    # Ignore or override!
    elsif ($special eq '%!()') {
	die "stub!";
    }

    # Recordset Global Variable or Template option
    elsif ($special =~ '%(RGV|T)') {
	$self->{$1}->{$key}=$value;
    }

    # Oup!
    elsif (2) {
	die "stub!";
    }

}

# Used in sub execute_recordsets.  Can be overridden.
sub load_recordset_class {
    my $self=shift;
    eval "require $$self{recordset_class}";

    for (keys %{$self->{'RGV'}}) {
	no strict 'refs';
	if (/^(Debug|PreserveCase|FetchsizeWarn)$/) {
	    $ {*{"$$self{recordset_class}::$1"}{SCALAR}}=$self->{'RGV'}->{$_};
	} else {

	    # Somebody (the web user or anyone with access to the
	    # parameter file or the (F)CGI script) has tried tom
	    # modify some variable (s)he's not allowed to update.

	    # I didn't see the need for setting other things than
	    # Debug, PreserveCase and FetchsizeWarn, if I'm wrong, the
	    # (Debug|PreserveCase|FetchsizeWarn) line above has to be
	    # modified (Better: put it as a package-global variable)

	    warn "Not allowed (check the code for more info)";
	}
    }
}

# Used in sub execute_recordsets.  Can be overridden.
sub massage_init_parameters {
    my $self=shift;
    my $p=shift;

    # Temporary.  This should be declared somewhere else.
    $p->{'!DBIAttr'}={RaiseError=>0, PrintError=>0};

    # Empty Usernames are perfectly valid in MySQL, and I
    # think it's more apropriate to have "" as default than
    # whatever user the webserver is running as.
    $p->{'!Username'} =
	$self->{params}->{default}->{'!Username'} || "";

    # Locally I have set up different security models; login
    # without a password (or by submitting a password in the
    # clear), login with password over a secure line, and a
    # login with a valid SSL certificate.  For the first I've
    # put on an extention "_nopass" to the username, the
    # latter "_ssl".  Anyway, the user shouldn't have to know
    # about those extentions.
    $p->{'!Username'} .=
	$p->{'!UsernameExtention'} || "";
    if (my $val=$p->{'!ConvertTimestampMysql2Iso'}) {
	for my $v (split /,/, $val) {
	    $p->{'!Filter'}->{$v}=
		[undef, \×tamp_mysql2iso]
	}
    }

    # Do this recursively
    for my $l (keys %{$p->{'!Links'}}) {
	$self->massage_init_parameters($p->{'!Links'}->{$l});
    }
}

# Used in sub execute_recordsets.  Can be overridden.
sub massage_where_parameters {
    my $self=shift;
    my $p=shift;

    # Support/expand the $substring_search parameter
    if (my $val=$p->{'$substring_search'}) {
	for (split(/,/, $val)) {
	    $p->{'*'.$_}=" LIKE ";
	    $p->{$_}= "%$$p{$_}%"
		unless exists $p->{'=update'}
	            || exists $p->{'=insert'}
                    || !$p->{$_};
	}
    }

    # Do this recursively
    for my $l (keys %{$p->{'!Links'}}) {
	$self->massage_where_parameters($p->{'!Links'}->{$l});
    }
}

sub execute_recordsets {
    my $self=shift;

    $self->{params}->{default}->{'!DoNothing'} && return;

    # Check for the special !RecordsetClass:
    $self->{recordset_class}=
	$self->{params}->{default}->{'!RecordsetClass'} ||
	    $Recordset_Class;

    $self->load_recordset_class();

    for my $query (keys %{$self->{params}}) {

	if ($self->{params}->{$query}->{'!SearchForm'}) {

	    # Set ?count
	    $self->{output}->{'?count'}=0;

	    # Make one empty LOOP element
	    $self->{output}->{$query}=[{}];

	} else {

	    $self->massage_init_parameters($self->{params}->{$query});

	    unless ($self->{recordsets}->{$query}=
		tie (@{$self->{output}->{$query}},
		     $self->{recordset_class},
		     $self->{params}->{$query})) {
		my $error=$DBIx::Recordset::LastError || $DBI::errstr
		    || die "Could not tie array and no error message present";
		$self->handle_error($error);
	    }

	    $self->massage_where_parameters($self->{params}->{$query});

	    $self->{recordsets}->{$query}->Execute($self->{params}->{$query})
		|| $self->handle_error($self->{recordsets}->{$query}->LastError())
		    if (defined $self->{recordsets}->{$query});

	    # If we have added/updated something, we usually also want to
	    # display the changes/new record:

	    if (0||$self->{params}->{default}->{'=update'} ||
		$self->{params}->{default}->{'=insert'}) {

		$self->{recordsets}->{$query}->Select($self->{params}->{$query})
		    || $self->handle_error($self->{recordsets}->{$query}->LastError())
			if (defined $self->{recordsets}->{$query});

	    }

	    # Copy the data if needed (Tie::ARRAY not implemented properly
	    # in earlier versions of perl + many DBMS'es doesn't give away
	    # the count anyway ... and the current version of HTML::Template
	    # need to know the size of the array.

	    no strict 'refs';

	    if ($ {*{"$$self{recordset_class}::FetchsizeWarn"}{SCALAR}} ||
		$]<5.00504) {
		# This really shouldn't be necessary :/
		my $hash_with_broken_arrays=$self->{output};
		$self->{output}={};
		&faenskopiering($hash_with_broken_arrays, $self->{output},
				$self->{recordsets}, $self->{params});
	    }

	    # Set ?count
	    $self->{output}->{'?count'}=scalar @{$self->{output}->{default}};
	}
    }
}

sub handle_error {
    my $self=shift;
    my $errorobject=shift;
    if (ref $errorobject) {
	die "stub!";
    } else {
	# Is this DBD-dependent?  I guess so.  It should be considered
	# if it can be done in some DBD-independent way.

	# First the client errors:
	if ($errorobject =~ /^Access denied/) {
	    $self->{status}->{error}="The database reported:\n$errorobject\n\nThis probably means either that you're using the wrong username, wrong password or that you haven't been granted access.";
	} else {

# We shouldn't give away the error message to the user (security
# reasons + that it's likely to be misunderstood by a stupid end user
# + that probably only the server administrator can do anything
# anyway).  Let's view a 500 page, preferable with lots of bells and
# whistles and even a banner to increase the income.

	    die $errorobject;
	}
    }
}

sub parse_template {
    my $self=shift;

    my $f=$self->{filename};

    # An alternative template might be chosen with the "!Goto" parameter
    my $g=$self->{params}->{'!Goto'} || undef ;

    # Let's see if there is an alternative template...
    # See the POD for naming conventions

    # Separate dir, base and ending
    my ($dir, $base, $ending) = $f =~ /(.*?)([^\/]*)\.(\w+)$/;

    # (I guess there might be problems under substandard OS'es using
    # different directory naming schemes.  As if I care.  But I might
    # be willing to accept a patch)

    my $st=$self->{status};

    if ($st->{error}) {
	$f="$dir$base.error.$ending";
	if (! -r $f) {
	    warn "Error: $$st{error} (error template not found)";
	    eval "require $Client_Error_Class";
	    $Client_Error_Class->error($$st{error}); return;
	}
    }

    my $cnt=$self->{output}->{'?count'};

    # templates with extentions found_more, found_one, found_none and
    # found_35 can be used.

    my $found1=($cnt>1 ? "found_more" : ($cnt==1 ? "found_one" : "found_none"));
    my $found2="found_".$cnt;

  STATUS_TEMPLATE:
    for ("update_ok", "delete_ok",
	 "add_ok", $found2, $found1) {
	if ($st->{$_}||/^found_/) {
	    if (-r "$g.$_.$ending") {
		$self->{filename}="$dir$g.$_.$ending";
		last STATUS_TEMPLATE;
	    } elsif (-r "$dir$base.$_.$ending") {
		$self->{filename}="$dir$base.$_.$ending";
		last STATUS_TEMPLATE;
	    }
	}
    }

    # Check for the special !TemplateClass:
    $self->{template_class}=
	$self->{params}->{default}->{'!TemplateClass'} ||
	    $Template_Class;

    eval "require $$self{template_class}";

    $self->{T}->{filename}=$self->{filename};

    my $template=$self->{template_class}->new(%{$self->{T}});

    no strict 'refs';

    $template->param(%{$self->{output}});

    if (my $http=$self->{params}->{default}->{'!HTTPHeaders'}) {
	print $http, "\n";
    } elsif (my $ct=$self->{params}->{default}->{'!ContentType'}) {
	print "Content-Type: $ct\n\n";
    }

    print $template->output;
}

# Recursive sub for copying the output hash. This one shouldn't be
# necessary ... but it seems like it is, due to the TIE not working as
# good as it should :(

# This sub will eventually produce weird results or even recurse
# forever if given hashes with "reused" data or looping references.
# So don't do it.

# Eventually I inserted other features here as well.  It's hacky, and
# should disappear.  The features are:

# - mod2
# - fetch_* (not supported, subqueries are always fetched here)
# - generate_booleans

sub faenskopiering {
    my $src=shift;
    my $dst=shift;
    my $rsh=shift; # What? Why? Shouldn't params be good enough, huh?
    my $params=shift;

    for (keys %$src) {
	if (ref $src->{$_} eq "ARRAY"
	    || $src->{$_} =~ /^\*DBIx::Recordset/) # Ouch, ugly, ugly, ugly..
	{
	    my $i=0;

	    # Aaaahhrgghajgkjgussakjlf!
	    my $links;
	    my $p;
	    if (defined $rsh && ref $rsh eq "HASH" && exists $rsh->{$_}) {
		$links=$rsh->{$_};
		$p=$params->{$_};
		if (defined $links && ref $links ne "HASH") {
		    $links=$links->Links();
		} else {
		    $links=$links->{'!Links'};
		}
	    }

	    while (my $z=$src->{$_}->[$i] || undef) {
		if (ref $z eq "HASH") {
		    $dst->{$_}->[$i]={};

		    # Feature hack to get mod2 working:
		    $dst->{$_}->[$i]->{'?mod2'}=$i%2;

		    # Feature hack to get generate_booleans working:
		    for my $k (split(/\,/, $p->{'$generate_booleans'})) {
			$dst->{$_}->[$i]->{$k.'_'.$src->{$_}->[$i]->{$k}}=1;
		    }

		    for my $l (keys %$links) {
			# gurgleblargefaensdritt!
			my $dumb=$src->{$_}->[$i]->{$l};
		    }
		    &faenskopiering($z, $dst->{$_}->[$i], $links, $p->{'!Links'});
		} else {
		    warn "This code shouldn't be executed?";
		    $dst->{$_}->[$i]=$z;
		}
		$i++;
	    }
	} elsif (ref $src->{$_} eq "HASH") {
	    &faenskopiering($src->{$_}, $dst->{$_});
	} else {
	    $dst->{$_}=$src->{$_};
	}
    }
}

sub timestamp_mysql2iso {
    $_=shift;
    /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
    return "$1-$2-$3 $4:$5:$6";
}



__END__