#!/Perl/bin/perl
package CatcherInTheRye;
use strict;
use warnings;
use base qw/CGI::Application/;
use CGI::Application::Plugin::Forward;
use CGI::Application::Plugin::Redirect;
use CGI::Application::Plugin::HTCompiled;
use CGI::Application::Plugin::Session;
use CGI::Application::Plugin::MessageStack;
use CGI::Application::Plugin::DBH (qw/dbh dbh_config/);
use Data::Dumper qw/Dumper/;
our $VERSION = 0.1;
=head1 NAME
CatcherInTheRye - a boring book
=head1 DESCRIPTION
Beispiel für die Verwendung von SQLite. create_db erzeugt eine Datenbank mit
Testdaten, explore_db zeigt die Testdaten an. Beides kann über den
start-runmode start erreicht werden.
=head1 METHODS
=cut
=head2 cgiapp_init()
Open database connection, setup config files, etc.
=cut
sub cgiapp_init {
my $self = shift;
# -- use the same args as DBI->connect();
my $db_cfg = {
dsn => 'dbi:SQLite:dbname=test.db',
username => '',
password => '',
attributes => {
RaiseError => 1,
AutoCommit => 1,
sqlite_unicode => 1,
},
};
$self->dbh_config($db_cfg->{dsn}, $db_cfg->{username}, $db_cfg->{password},
$db_cfg->{attributes});
# -- configure CAP::MessageStack to auto clear messages
$self->capms_config(
-automatic_clearing => 1,
);
} # /cgiapp_init
=head2 setup()
Defined runmodes, etc.
=cut
sub setup {
my $self = shift;
$self->start_mode('start');
$self->run_modes([qw/
start
create_db
explore_db
/]);
} # /setup
=head2 start()
Zeige ein Formular, mit dem die Datenbank erstellt werden kann + den Link zur
Anzeige der Datenbank-Daten. Die Datenbank sollte wahrschienlich besser erzeugt
werden, *bevor* deren Inhalt angezeigt wird.
=cut
sub start {
my $self = shift;
my $tmpl = q~
SQLite-Test
Test von SQLite
">
explore db
~;
my $t = $self->load_tmpl(\$tmpl);
return $t->output();
} # /start
=head2 create_db()
Create a SQLite databse and fill in some values.
=cut
sub create_db {
my $self = shift;
my $dbh = $self->dbh();
$dbh->do(q{DROP TABLE If EXISTS persons});
$dbh->do(q{
CREATE TABLE persons (
id INTEGER PRIMARY KEY AUTOINCREMENT,
first_name VARCHAR(255),
last_name VARCHAR(255)
)
});
$dbh->do(q{DROP TABLE If EXISTS groups});
$dbh->do(q{
CREATE TABLE groups (
id INTEGER PRIMARY KEY AUTOINCREMENT,
title VARCHAR(255)
)
});
$dbh->do(q{DROP TABLE If EXISTS persons2groups});
$dbh->do(q{
CREATE TABLE persons2groups (
id INTEGER PRIMARY KEY AUTOINCREMENT,
person_id INTEGER,
group_id INTEGER
)
});
my $grp_stmt = $dbh->prepare(q{INSERT INTO groups (title) VALUES (?)});
for my $data ( 'admin', 'user', 'guest' ) {
$grp_stmt->execute($data);
}
my $usr_stmt = $dbh->prepare(q{
INSERT INTO persons (first_name, last_name) VALUES (?, ?)});
for my $data ( ['mr.','admin'], ['mäh','maz'], ['john','smith'] ) {
$usr_stmt->execute(@{$data}[0,1]);
}
my $usr_grp_stmt = $dbh->prepare(q{
INSERT INTO persons2groups (person_id, group_id) VALUES (?, ?)});
for my $data ( [1,1], [1,2], [1,3], [2,3], [3,2] ) {
$usr_grp_stmt->execute(@{$data}[0,1]);
}
$self->push_message(
-scope => 'start',
-message => localtime() . ' - Your db has been created',
-classification => 'INFO',
);
return $self->redirect( $self->query->url() . '?rm=start' );
} # /create_db
=head2 explore_db()
Display some data.
=cut
sub explore_db {
my $self = shift;
my $dbh = $self->dbh();
my $sth = $dbh->prepare(q{SELECT * FROM persons})
or die('error preparing: ' . DBI->errstr());
my $rv = $sth->execute() or die('error executing: ' . DBI->errstr());
my @all_persons_loop = ();
while( my $user_data = $sth->fetchrow_hashref ) {
my $user_id = $user_data->{id};
my %data_of_one_user = (
first_name => $user_data->{first_name},
last_name => $user_data->{last_name},
groups => [], # we don't have those yet
);
# -- now get the groups
my $grp_sth = $dbh->prepare(q{
SELECT g.title
FROM persons2groups p2g
LEFT JOIN groups g ON g.id = p2g.group_id
WHERE person_id = ?
}) or die('error preparing: ' . DBI->errstr());
my $grp_rv = $grp_sth->execute($user_id)
or die('error executing: ' . DBI->errstr());
while( my $grp_data = $grp_sth->fetchrow_arrayref() ) {
# -- Bitte fragen, wenn das unklar ist:
push @{$data_of_one_user{'groups'}}, { title => $grp_data->[0] };
}
push @all_persons_loop, \%data_of_one_user;
}
my $tmpl = q~
zurück
,
Mitglied in folgenden Gruppen:
So sieht die Datenstruktur aus:
~;
my $t = $self->load_tmpl(\$tmpl);
$t->param('dump' => Dumper(\@all_persons_loop));
$t->param('all_persons' => \@all_persons_loop);
return $t->output();
} # /explore_db
=head1 LICENSE
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself, either Perl version 5.8.8 or, at your option,
any later version of Perl 5 you may have available.
=cut
1;
use strict;
use warnings;
use FindBin qw/$Bin/;
my $app = CatcherInTheRye->new();
$app->run();