use strict;
package # thwart the PAUSE indexer
CAF_MB_Installer;
use base 'Module::Build';
use File::Spec ();
use HTML::Template;
use Cwd;
use File::Path;
use File::Find;
use Carp;
=for comment
This is an attempt to make an installer that handles files not normally
handled by Module::Build:
caf_cgi_files # get installed in user's cgi-bin or cgi-sec directory
# get shbang line properly set to #!/usr/bin/perl (or local equiv)
# are set to be executable
# are run through template to localize paths
caf_htdoc_files # are installed in subdirectory of user's webroot (e.g. /caf-examples)
# are run through template to localize paths
caf_config_files # are installed in the project directory
# are run through template to localize paths
caf_img_files # are installed in images subdirectory of user's webroot (e.g. /caf-examples/images)
caf_project_files # are installed in project subdirectory of user's webroot (e.g. /caf-examples/images)
caf_server_files # installed in caf framework directory. Also, an an attempt is made
# to make these owned by the webserver
=cut
sub caf_add_examples_build_elements {
my $self = shift;
$self->add_build_element('caf_cgi');
$self->add_build_element('caf_htdoc');
$self->add_build_element('caf_image');
$self->add_build_element('caf_config');
$self->add_build_element('caf_project');
$self->add_build_element('caf_server');
$self->add_build_element('caf_sql');
}
# Override the install action to also install certain directories
# required by CAF at runtime. These directories need to be writeable by
# the webserver, so an effort is made to change their ownership
sub ACTION_install {
my $self = shift;
$self->SUPER::ACTION_install(@_);
my $user = $self->notes('examples_user_num');
my $group = $self->notes('examples_group_num');
$self->caf_install_example_files($self->caf_install_map, 1, $user, $group);
$self->caf_fix_server_directories;
}
sub caf_fix_server_directories {
my $self = shift;
# after the regular install has completed,
# install server directories (relative to destdir)
return unless $self->notes('install-examples');
my $verbose = $self->{properties}->{verbose};
print "Installing Server Paths... \n" if $verbose;
my @server_paths = (
$self->notes('path_sqlite'),
$self->notes('path_weblog'),
$self->notes('path_session_dir'),
$self->notes('path_session_locks'),
);
my @server_files = (
$self->notes('file_sqlite_db'),
);
my $uid = $self->notes('web_server_user_num');
my $gid = $self->notes('web_server_group_num');
my $destdir = $self->{properties}{destdir} || '';
foreach my $server_path (@server_paths) {
if ($destdir) {
# Need to remove volume from $map{$_} using splitpath, or else
# we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
my ($volume, $path) = File::Spec->splitpath( $server_path, 1 );
$server_path = File::Spec->catdir($destdir, $path);
}
}
foreach my $server_file (@server_files) {
if ($destdir) {
# Need to remove volume from $map{$_} using splitpath, or else
# we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
my ($volume, $path, $file) = File::Spec->splitpath( $server_file );
$server_file = File::Spec->catdir($destdir, $path, $file);
}
}
foreach my $server_path (@server_paths) {
File::Path::mkpath($server_path, 0, 0777);
}
foreach my $server_path (@server_paths, @server_files) {
# skip chown on Win32 - instead notify the user
if ($^O =~ /Win32/) {
print "Make sure this path is writeable by your webserver:\n\t$server_path\n";
next;
}
print "making path writeable by webserver: $server_path\n" if $verbose;
chown $uid, $gid, $server_path
or warn "Could not make the following path writeable by the webserver - you'll have to do it manually:\n\t$server_path\n";
# Make writeable
my $current_mode = (stat $server_path)[2];
chmod $current_mode | 0600, $server_path;
}
}
sub find_caf_cgi_files { shift->_find_file_by_type('.*', 'caf_cgi' ) }
sub find_caf_config_files { shift->_find_file_by_type('conf', 'caf_config' ) }
sub find_caf_htdoc_files { shift->_find_file_by_type('(html?)|(css)', 'caf_htdoc' ) }
sub find_caf_image_files { shift->_find_file_by_type('(png)|(jpg)|(gif)', 'caf_image' ) }
sub find_caf_project_files { shift->_find_file_by_type('.*', 'caf_project' ) }
sub find_caf_server_files { shift->_find_file_by_type('.*', 'caf_server' ) }
sub find_caf_sql_files { shift->_find_file_by_type('.*', 'caf_sql' ) }
sub caf_type_is_static {
my ($self, $ext) = @_;
return 1 if $ext eq 'caf_project';
return 1 if $ext eq 'caf_image';
return 1 if $ext eq 'caf_server';
return;
}
sub process_files_by_extension {
my $self = shift;
my ($ext) = @_;
# skip special processing for non-caf
unless ($ext =~ /^caf_/) {
return $self->SUPER::process_files_by_extension(@_);
}
my $method = "find_${ext}_files";
my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib');
while (my ($file, $dest) = each %$files) {
my $source = $file;
my $target = File::Spec->catfile($self->blib, $dest);
return if $self->up_to_date($source, $target);
# caf_images and caf_project are a simple copy
if ($self->caf_type_is_static($ext)) {
$self->copy_if_modified(from => $source, to => $target);
}
else {
# Make parent directory
File::Path::mkpath(File::Basename::dirname($target), 0, 0777);
my $template = HTML::Template->new(
filename => $source,
die_on_bad_params => 0,
filter => sub {
my $text_ref = shift;
# Convert !!- var -!! to <TMPL_VAR var>
$$text_ref =~ s/!!-\s*(.*?)\s*-!!/<TMPL_VAR "$1">/g;
},
);
my $notes = $self->notes;
$template->param(%$notes);
my $output = $template->output;
open my $fh, '>', $target or die "Can't overwrite target: $!";
print $fh $output;
close $fh;
if ($ext eq 'caf_cgi') {
$self->fix_shebang_line($target);
$self->make_executable($target);
}
}
}
}
# caf_install_example_files is adapted from ExtUtils::Install::install,
# with the following changes:
# - removed all the arcane bits about packlists and archlibs and whatnot
# - allows you to specify a user and group for ownership of the resulting files and directories
# - doesn't try to make the files read only - instead it respsects the current user's umask
# (note that umask might not be correct if the user is installing on behalf of a different user,
# e.g. a web virtual host user with a restrictive group)
#
sub forceunlink {
chmod 0666, $_[0];
unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
}
sub caf_install_example_files {
my ($self,$from_to,$verbose,$user,$group) = @_;
$verbose ||= 0;
my $is_vms = $^O eq 'VMS';
my $cwd = Cwd::cwd();
foreach my $source_path (sort keys %$from_to) {
my $targetroot = $from_to->{$source_path};
chdir $source_path or next;
File::Find::find(sub {
my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
return unless -f _;
my $origfile = $_;
return if $origfile eq ".exists";
my $targetdir = File::Spec->catdir( $targetroot, $File::Find::dir);
my $targetfile = File::Spec->catfile( $targetdir, $origfile);
my $sourcedir = File::Spec->catdir( $source_path, $File::Find::dir);
my $sourcefile = File::Spec->catfile( $sourcedir, $origfile);
my $save_cwd = Cwd::cwd;
chdir $cwd; # in case the target is relative
# 5.5.3's File::Find missing no_chdir option.
my $diff = 0;
if ( -f $targetfile && -s _ == $size) {
# We have a good chance, we can skip this one
$diff = File::Compare::compare($sourcefile, $targetfile);
} else {
print "$sourcefile differs\n" if $verbose>1;
$diff++;
}
# TODO:
# currently if the target file is the same as the source file,
# the file is not installed.
#
# However, no check is made to see if the file metadata is wrong.
# So you can't just run ./Build install to fix broken permissions -
# you actually have to delete the target files.
#
# I'm not sure I understand the reason for the diff check anyway.
# If the local file is different it is clobbered, so it can't be
# about preserving local changes.
#
# So is it for performance or to conserve resources? If so,
# why bother? This is just an install script that gets run very
# rarely. And it's exceptionally rare that the copying is skipped
# because the files haven't changed.
#
# Anyway, for now, we go with the same behaviour that is in
# ExtUtils::Install, but in the future, we may change.
if ($diff){
if (-f $targetfile){
forceunlink($targetfile);
}
else {
File::Path::mkpath($targetdir,0,0755);
print "mkpath($targetdir,0,0755)\n" if $verbose>1;
if ($user && $group) {
chown $user, $group, $targetdir;
print "chown($user, $group, $targetdir)\n" if $verbose>1;
}
}
File::Copy::copy($sourcefile, $targetfile);
print "Installing $targetfile\n";
utime($atime,$mtime + $is_vms, $targetfile);
print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
# We don't change the mode of the files, since these are
# example files and should be installed with permissions
# that respect the users umask
# However, if the original file was executable, make
# the new file executable too
my $executable = (stat $sourcefile)[2] & 0111;
if ($executable) {
my $mode = (stat $targetfile)[2];
$mode = $mode | $executable;
chmod $mode, $targetfile;
print "chmod($mode, $targetfile)\n" if $verbose>1;
}
# MAG - allow changing ownership of installed files
if ($user && $group) {
chown $user, $group, $targetfile;
print "chown($user, $group, $targetfile)\n" if $verbose>1;
}
}
else {
print "Skipping $targetfile (unchanged)\n" if $verbose;
}
# File::Find can get confused if you leave the directory it
# placed you in so we chdir back to the directory it put us in.
chdir $save_cwd;
}, File::Spec->curdir);
# After each copying run, return to the main directory
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
}
}
# Tell MB where to install our special files
sub caf_install_map {
my ($self, $blib) = @_;
$blib ||= $self->blib;
my %install_map;
if ($self->notes('install-examples')) {
my %caf_map = (
'caf_cgi' => $self->notes('path_examples_cgi_bin'),
'caf_htdoc' => $self->notes('path_examples_htdocs'),
'caf_image' => $self->notes('path_examples_images'),
'caf_config' => $self->notes('path_projects_dir'),
'caf_project' => $self->notes('path_projects_dir'),
'caf_server' => $self->notes('path_framework_root'),
'caf_sql' => $self->notes('path_sql_dir'),
);
# Taken directly from Module::Build::Base
if (length(my $destdir = $self->{properties}{destdir} || '')) {
foreach (keys %caf_map) {
# Need to remove volume from $map{$_} using splitpath, or else
# we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
my ($volume, $path) = File::Spec->splitpath( $caf_map{$_}, 1 );
$caf_map{$_} = File::Spec->catdir($destdir, $path);
}
}
foreach my $dir (keys %caf_map) {
my $blib_dir = File::Spec->catdir($blib, $dir);
$install_map{$blib_dir} = $caf_map{$dir};
}
}
return \%install_map;
}
###################################################################
# User input methods
###################################################################
sub prompt {
my $self = shift;
my $value;
while (1) {
$value = $self->SUPER::prompt(@_);
last unless $value =~ /\010/; # backspace pressed, leaving
# us with some ^H characters, so redo
};
return $value;
}
sub multiple_choice {
my $self = shift;
my %args = @_;
# if there is a predefined value, skip the question and return it
return $args{'pre_defined'} if $args{'pre_defined'};
my $name = $args{'question_name'};
my $preamble = $args{'preamble'};
my $prompt = $args{'prompt'};
my $default = $args{'default'} || '';
my $choices = $args{'choices'};
$choices = [$choices] unless ref $choices eq 'ARRAY';
# Remove leading whitespace from the preamble text
if ($preamble) {
my @lines = split /\r?\n/, $preamble;
my $whitespace = '';
foreach my $line (@lines) {
if (!$whitespace && $line =~ /^(\s*)/) {
$whitespace = $1;
}
$line =~ s/^$whitespace//;
print $line, "\n";
}
}
my $choice;
if (@$choices > 1) {
$prompt ||= "$name (pick a number or type a path)";
for (my $i = 0; $i < @$choices; $i++) {
my $item = $choices->[$i];
my $num = $i + 1;
print " [$num]: $item\n";
}
print "\n";
while (1) {
$choice = $self->prompt($prompt, $default);
if ($choice =~ /^\d+$/) {
$choice -= 1; # make zero based
redo if $choice < 0 or $choice > (@$choices-1);
$choice = $choices->[$choice];
}
last;
}
}
else {
$prompt ||= "$name";
$choice = $self->prompt($prompt, $default);
}
$choice ||= $default;
return $choice;
}
1;