File Coverage

blib/lib/CGI/Application/Demo/Basic.pm

Criterion	Covered	Total	%
statement	24	181	13.2
branch	0	18	0.0
condition	0	10	0.0
subroutine	8	20	40.0
pod	3	12	25.0
total	35	241	14.5

package CGI::Application::Demo::Basic;

# Documentation:
#	POD-style documentation is at the end. Extract it with pod2html.*.
#
# Note:
#	o tab = 4 spaces || die
#
# Author:
#	Ron Savage
#	http://savage.net.au/index.html

use base 'CGI::Application';
use strict;
use warnings;

require 5.005_62;

use CGI::Application::Demo::Basic::Util::Config;
use CGI::Application::Plugin::LogDispatch;
use CGI::Application::Plugin::Session;
use CGI::Simple;
use Class::DBI::Loader;

our $VERSION = '1.06';

# -----------------------------------------------

sub build_basic_pane
{
	my($self, $submit) = @_;
	my($content)       = $self -> load_tmpl('basic.tmpl');
	my($count)         = $self -> session -> param('count') || 0;

	$count++;

	$self -> session -> param(count => $count);

	my(@tr_loop);

	for my $table (sort keys %{$self -> param('cgi_app_demo_tables')})
	{
		my($class)       = ${$self -> param('cgi_app_demo_tables')}{$table};
		my(@column)      = $self -> get_columns($class);
		my(@column_name) = sort @{$column[2]};

		push @tr_loop,
		{
			th => 'Table',
			td => $table,
		},
		{
			th => 'Class',
			td => $class,
		},
		{
			th => 'Columns',
			td => join(', ', @column_name),
		},
	}

	$content -> param(count => "sub build_basic_pane has run $count time(s)");
	$content -> param(tr_loop => \@tr_loop);
	$content -> param(commands => $self -> build_commands_output
	([
		'Refresh',
	]) );
	$content -> param(notes => $self -> build_notes_output
	([
		'Hint: Click Refresh (below)',
		"Previous command: $submit",
	]) );

	return $content -> output;

}	# End of build_basic_pane.

# -----------------------------------------------

sub build_commands_output
{
	my($self, $command)   = @_;
	my($content)          = $self -> load_tmpl('commands.tmpl');
	my(@loop)             = ();
	my($max_column_count) = $self -> param('columns_of_commands_option');
	my($row_count)        = int( (@$command + $max_column_count - 1) / $max_column_count);
	my($command_index)    = - 1;

	my($row, $col);

	for $row (1 .. $row_count)
	{
		my(@td_loop);

		for $col (1 .. $max_column_count)
		{
			$command_index++;

			next if ($command_index > $#$command);

			if (ref($$command[$command_index]) eq 'ARRAY')
			{
				push @td_loop, {td => $$command[$command_index][0], onClick => $$command[$command_index][1]};
			}
			else
			{
				push @td_loop, {td => $$command[$command_index]};
			}
		}

		push @loop, {col_loop => \@td_loop};
	}

	$content -> param(commands => $#$command == 0 ? 'Command' : 'Commands');
	$content -> param(row_loop => \@loop);

	return $content -> output;

}	# End of build_commands_output.

# -----------------------------------------------

sub build_notes_output
{
	my($self, $note) = @_;
	my($content)     = $self -> load_tmpl('notes.tmpl');
	my(@loop)        = ();

	push @loop, {td => $_} for (@$note);

	$content -> param(note_loop => \@loop);

	return $content -> output;

}	# End of build_notes_output.

# -----------------------------------------------

sub build_options_pane
{
	my($self, $submit) = @_;
	my($content)       = $self -> load_tmpl('options.tmpl');
	my(@key)           = sort keys %{${$self -> param('key')}{'option'} };

	my(@loop, $minimum, $maximum, $s);

	for (@key)
	{
		$minimum = ${$self -> param('key')}{'option'}{$_}{'minimum'};
		$maximum = ${$self -> param('key')}{'option'}{$_}{'maximum'};
		($s      = $_) =~ s/_option$//;
		$s       =~ tr/_/ /;
		$s       = "Number of $s ($minimum .. $maximum)";

		push @loop,
		{
			option => $s,
			name   => $_,
			value  => $self -> session -> param($_),
		};
	}

	$content -> param(commands => $self -> build_commands_output
	([
		['Update options', q|onClick = "set('update_options')"|],
	]) );
	$content -> param(notes => $self -> build_notes_output
	([
		'DSN: ' . $self -> param('dsn'),
		"Previous command: $submit",
	]) );
	$content -> param(tr_loop => \@loop);

	return $content -> output;

}	# End of build_options_pane.

# -----------------------------------------------

sub cgiapp_get_query
{
	my($self) = @_;

	return CGI::Simple -> new;

}	# End of cgiapp_get_query.

# -----------------------------------------------

sub cgiapp_init
{
	my($self)   = @_;
	my($config) = CGI::Application::Demo::Basic::Util::Config -> new('basic.conf') -> config;

	# All this stuff is here so that we can call
	# CGI::Application::Plugin::LogDispatch's log_config, if at all,
	# in cgiapp_init (as suggested by its docs) rather than in setup.

	$self -> param(config => $config);
	$self -> param(css_url => $$config{'css_url'});
	$self -> param(dsn => $$config{'dsn'});
	$self -> param(title => $$config{'dsn'});
	$self -> param(tmpl_path => $$config{'tmpl_path'});

	# Set up the classes for each table, via the magic of Class::DBI.
	# I have used a constraint because this is a demo, and I've only
	# created one module for Class::DBI to chew on:
	# CGI::Application::Demo::Basic::Faculty.

	my($loader) = Class::DBI::Loader -> new
	(
		constraint    => '^faculty$',
		dsn           => $$config{'dsn'},
		user          => $$config{'username'},
		password      => $$config{'password'},
		options       => $$config{'dsn_attribute'},
		namespace     => '',
		relationships => 1,
	);

    $self -> setup_db_interface($loader);
	$self -> param(dbh => ${$self -> param('cgi_app_demo_classes')}[0] -> db_Main);

	# Set up interface to logger.

	$self -> log_config
	(
		LOG_DISPATCH_MODULES =>
		[{
			dbh       => $self -> param('dbh'),
			min_level => 'info',
			module    => 'CGI::Application::Demo::Basic::Util::LogDispatchDBI',
			name      => __PACKAGE__,
		},
		]
	);

	# Set up interface to CGI::Session.

	$self -> session_config
	(
		CGI_SESSION_OPTIONS => [$$config{'session_driver'}, $self -> query, {Handle => $self -> param('dbh')}],
		DEFAULT_EXPIRY      => $$config{'session_timeout'},
		SEND_COOKIE         => 0,
	);

	# Recover options from session, if possible.
	# If not, initialize them.
	# This hash holds details of the set of options.

	$self -> param(key =>
	{
		option =>
		{
			columns_of_commands_option =>
			{
				default => 3,
				maximum => 20,
				minimum => 1,
				size    => 2,
				type    => 'integer',
			},
			records_per_page_option =>
			{
				default => 100,
				maximum => 1000,
				minimum => 1,
				size    => 4,
				type    => 'integer',
			},
		},
	});

	my(@key) = keys %{${$self -> param('key')}{'option'} };

	$self -> param($_ => $self -> session -> param($_) ) for @key;

	# Pick any option to see if they've all be initialized.

	if (! $self -> param('records_per_page_option') )
	{
		my($value);

		for (@key)
		{
			$value = ${$self -> param('key')}{'option'}{$_}{'default'};

			$self -> param($_ => $value);
			$self -> session -> param($_ => $value);
		}
	}

}	# End of cgiapp_init.

# --------------------------------------------------
# Note: This code retrieves the config in order to access 'dsn'.
# This illustrates a different method of accessing config data
# than, say, sub setup. The latter uses the fact that some data
# (tmpl_path) has been copied out of the config into an app param.
# This copying took place near the start of sub cgiapp_init.
# In the same way (as the latter technique) sub start uses
# css_url, which was also copied in sub cgiapp_init.

sub db_vendor
{
	my($self)   = @_;
	my($config) = $self -> param('config');
	my($vendor) = $$config{'dsn'} =~ /[^:]+:([^:]+):/;

	return uc $vendor;

}	# End of db_vendor.

# -----------------------------------------------
# Given a class we return an array of 3 elements:
# 0: An array ref of primary column names
# 1: An array ref of all other column names
# 2: An array ref of all column names
# The names are in the order returned by the class, which is best because
# the database designer probably set up the table with the columns in a
# specific order, and the names of the primary key columns are in a
# specific order anyway. And the caller can sort the [1] if desired.

sub get_columns
{
	my($self, $class)   = @_;
	my(@column)         = $class -> columns;
	my(@primary_column) = $class -> primary_columns;

	my(%primary_column);

	@primary_column{@primary_column} = (1) x @primary_column;
	my(@other_column)                = grep{! $primary_column{$_} } @column;

	return ([@primary_column], [@other_column], [@column]);

}	# End of get_columns.

# -----------------------------------------------

sub setup
{
	my($self) = @_;

	$self -> run_modes(start => \&start, update_options => \&update_options);
	$self -> tmpl_path($self -> param('tmpl_path') );

}	# End of setup.

# -----------------------------------------------

sub setup_db_interface
{
	my($self, $parameter ) = @_;
	my($classes)           = [];

	if (ref($parameter) eq 'ARRAY')
	{
		for my $cdbi_class (@$parameter)
		{
			# Check to see if it's loaded already.

			if (! $cdbi_class::)
			{
				my($file) = $cdbi_class;
				$file     =~ s|::|/|g;

				eval
				{
					require "$file.pm";

					$cdbi_class -> import;
				};

				die "CGI::Application::Demo::Basic::setup_db_interface: Couldn't require class: $cdbi_class: $@" if ($@);
			}

			push @$classes, $cdbi_class;
		}
	}
	elsif (ref($parameter) =~ /^Class::DBI::Loader/)
	{
		push @$classes, $_ for $parameter -> classes;
	}
	else
	{
		my($ref) = ref($parameter);

		die "CGI::Application::Demo::Basic::setup_db_interface: Invalid parameter\nParameter must either be an array reference of Class::DBI classes or a Class::DBI::Loader object\nYou gave me a $ref object.";
	}

	$self -> param(cgi_app_demo_classes => $classes);

	my($tables) = {};

	for my $cdbi_class (@{$self -> param('cgi_app_demo_classes')})
	{
		my($table)       = $cdbi_class -> table;
		$$tables{$table} = $cdbi_class;
	}

	$self -> param(cgi_app_demo_tables => $tables);

}	# End of setup_db_interface.

# -----------------------------------------------

sub start
{
	my($self)     = shift;
	my($config)   = $self -> param('config');
	my($submit)   = $self -> query -> param('submit') || '';
	my($template) = $self -> load_tmpl($$config{'tmpl_name'});
	my($content)  = $self -> build_basic_pane($submit) . $self -> build_options_pane($submit);

	$template -> param(content => $content);
	$template -> param(css_url => $self -> param('css_url') );
	$template -> param(rm => $self -> query -> param('rm') );
	$template -> param(sid => $self -> session -> id);
	$template -> param(title => $self -> param('title') );
	$template -> param(url => $self -> query -> url . $self -> query -> path_info);

	return $template -> output;

}	# End of start.

# -----------------------------------------------

sub update_options
{
	my($self) = @_;
	my(@key)  = keys %{${$self -> param('key')}{'option'} };

	$self -> log -> info('Called update_options');

	my($value, $default, $minimum, $maximum);

	for (@key)
	{
		$default = ${$self -> param('key')}{'option'}{$_}{'default'};
		$minimum = ${$self -> param('key')}{'option'}{$_}{'minimum'};
		$maximum = ${$self -> param('key')}{'option'}{$_}{'maximum'};
		$value   = $self -> query -> param($_);
		$value   = $default if (! defined($value) || ($value < $minimum) || ($value > $maximum) );

		$self -> param($_ => $value);
		$self -> session -> param($_ => $value);
	}

	return $self -> start;

}	# End of update_options.

# -----------------------------------------------

1;

__END__