OK. Here is the new application generator:
% perl maypole-install dbi:mysql:sermons
I couldn't load the Authentication::UserSessionCookie plugin, which you might
want to use to authenticate users from your 'user' table. Run with --noauth to
disable this error
Oops.
% perl maypole-install --noauth dbi:mysql:sermons
Creating sermons/
Changing to sermons/
Creating Sermons/
Creating templates/
Writing Sermons.pm
Writing Sermons/Config.pm
Writing Sermons/DBI.pm
Writing Sermons/Category.pm
Writing Sermons/Day.pm
Writing Sermons/Filetype.pm
Writing Sermons/Occasion.pm
Writing Sermons/Passage.pm
Writing Sermons/Preacher.pm
Writing Sermons/Resource.pm
Writing Sermons/User.pm
Linking factory templates...
Creation complete.
----
<Perl>
push @INC, "/Users/simon/maypole/sermons";
</Perl>
<Location /sermons>
SetHandler perl-script
PerlHandler Sermons
</Location>
---
Paste that in, restart Apache, and we have a working Maypole app.
I think this is a Good Thing. It doesn't handle relationships yet,
because I can't be bothered to mess about with foreign keys in my databases,
but there's no reason why someone who understands ->meta_info wouldn't be
able to get that working.
Oh, yeah, it does require the factory templates to be moved into
lib/Maypole/templates/factory before you install Maypole.
Try it, it's fun.
--
Grr... don't get me started on Wagner. The man couldn't resolve a
dominant seventh to a tonic with two musical dictionaries open to the
word "resolution", and a copy of anything by Muddy Waters.
- Eric the Read, in the monastery.
#!/usr/bin/perl
use Cwd;
use Pod::Usage;
use Getopt::Long;
my %opt;
GetOptions(\%opt, "url=s", "help", "username=s", "password=s",
"project=s", "noauth", "noapache");
pod2usage() if $opt{help};
my $dsn = shift
or pod2usage("You need to pass in a DBI DSN for me to set you up");
eval "require Maypole" or die "Hey, you don't even have Maypole installed.
That's not going to work.\n";
require_or_die("DBI", "use your database");
require_or_die("Class::DBI::Loader", "use your database");
my $dbh = DBI->connect($dsn, $opt{username}, $opt{password})
or die "Couldn't connect to your database: $DBI::errstr";
my $project = $opt{project}||ucfirst $dbh->{Name};
my $dir = lc $project;
$opt{base} ||= "http://localhost/$dir/";;
my $driver = $dbh->{Driver}->{Name};
require_or_die("Class::DBI::Loader::$driver", "probe your database for tables");
if (!$opt{noapache}) {
require_or_die("Apache::Request", "use Apache for this application (call
with --noapache to avoid this message)")
}
use strict;
my $loader = Class::DBI::Loader->new(
dsn => $dsn,
namespace => $project,
user => $opt{username},
password => $opt{password},
relationships => 1
);
if ($loader->find_class("user") and not $opt{noauth}) {
eval "require Maypole::Plugin::Authentication::UserSessionCookie";
if ($@ =~ /Can't locate/) {
die "I couldn't load the Authentication::UserSessionCookie plugin,
which you might want to use to authenticate users from your 'user' table. Run
with --noauth to disable this error\n";
}
$opt{doauth}++;
}
die "Directory $dir/ already exists, not overwriting\n" if -d $dir;
die "$dir already exists, but I need to put a directory there\n" if -e $dir;
my_mkdir($dir);
print "Changing to $dir/\n"; chdir($dir);
my_mkdir("$project");
my_mkdir("templates");
write_out("$project.pm", fill_template(base_template()));
write_out("$project/Config.pm", fill_template(config_template()));
write_out("$project/DBI.pm", fill_template(dbi_template()));
for my $class ($loader->classes) {
my $file = $class; $file =~ s/::/\//; $file .= ".pm";
write_out($file, fill_template(table_template(), class=> $class, class_o =>
bless{},$class));
}
my $path = $INC{"Maypole.pm"}; $path =~ s{\.pm}{\/templates/factory/};
if (!-d $path) {
warn "I didn't find the Maypole templates installed in $path, so I can't
link the factory templates in for you.\n";
} else {
print "Linking factory templates...\n";
symlink($path, "templates/factory");
}
print "Creation complete.\n";
print "----\n\n\n";
print "<Perl>\n push [EMAIL PROTECTED], \"".getcwd()."\";\n</Perl>\n";
my $loc = URI->new($opt{base})->path;
$loc =~ s/\/$//;
print "<Location $loc>\n";
print " SetHandler perl-script\n PerlHandler $project\n";
print "</Location>\n\n";
sub fill_template {
require_or_die("Template", "create templated module code");
my ($template, @stuff) = @_;
my $output = "";
my $tt = Template->new();
$tt->process(\$template, {
project => $project,
driver => $driver,
dsn => $dsn,
dbh => $dbh,
loader => $loader,
opt => \%opt,
cwd => getcwd(),
base => $opt{base},
dbname => $dbh->{Name},
@stuff
}, \$output)
|| die "Filling the template failed: ",$tt->error(), "\n";
$output;
}
sub table_template {
<<'EOF'
package [% class %];
use base qw([%project%]::DBI Maypole::Model::CDBI::Plain);
[% class %]->table("[%class_o.table%]");
[% class %]->columns(All => qw/ [%FOR c=class_o.columns; NEXT IF c=="id"; c _ "
"; END%] /);
1;
EOF
}
sub base_template {
<<'EOF'
package [%project%];
use Maypole::Application[% IF opt.doauth; "
(qw(Authentication::UserSessionCookie))"; END;%];
use [%project%]::Config;
use [%project%]::DBI;
[% FOR c = loader.classes %] use [% c %];
[% END %]
[%project%]->config->model("Maypole::Model::CDBI::Plain");
[%project%]->setup([qw/ [%loader.classes.join(" ")%] /]);
[% IF opt.doauth %]
sub authenticate {
my ($self, $r) = @_;
$r->get_user;
}
[% END %]
1
EOF
}
sub config_template {
<<'EOF'
package [%project%]::Config;
use [%project%];
[%project%]->config->uri_base("[%base%]");
[%project%]->config->{dsn} = "[%dsn%]";
[%project%]->config->{template_root} = "[%cwd%]/templates/";
1;
EOF
}
sub dbi_template {
<<'EOF'
package [%project%]::DBI;
use [%project%];
use [%project%]::Config;
use base 'Class::DBI::[%driver%]';
__PACKAGE__->connection([%project%]->config->{dsn});
__PACKAGE__->autoupdate(1);
1;
EOF
}
sub write_out {
my ($file, $text) = @_;
print "Writing $file\n";
open OUT, ">$file" or die "Couldn't write on $file, $!";
print OUT $text;
close OUT;
}
sub my_mkdir { my $dir = shift;
print "Creating $dir/\n";
mkdir($dir) or die "mkdir failed for $dir - $1" }
sub require_or_die {
my ($module, $reason, $ours) = @_;
eval "require $module";
return unless $@;
if ($ours) {
die "We created $module, but it doesn't work - which should never
happen. Sorry. Hopefully this error message will help: [EMAIL PROTECTED]";
}
if ($@ =~ /Can't locate (\S+)/) {
my $module2 = $1;
$module2 =~ s/.pm$//; $module2 =~ s/\//::/g;
die "You don't seem to have the $module module installed, which I need
to $reason. (We could install it for you but thought that would be a bit rude.
We suggest 'cpan install $module')\n" if $module2 eq $module;
die "$module, which we need to $reason, didn't load because you don't
seem to have $module2 installed, which it needs. (But didn't declare as a
prerequisite when you installed it, which is arguably a bug. Hey ho.)\n" if
!$ours;
}
die "I tried to use $module so I can $reason, but I was told: [EMAIL
PROTECTED]";
}
=head1 NAME
maypole-install - Get you up and running with a Maypole application
=head1 SYNOPSIS
maypole-install [options] dsn
Options:
--url Base of the web application's URL
--project Project name
--help This text
