Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2646 lines (2384 sloc) 61.335 kB
# Vend::MakeCat - Routines for Interchange catalog configurator
#
# $Id: MakeCat.pm,v 2.10 2002-06-27 22:24:10 jon Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
# This program was originally based on Vend 0.2 and 0.3
# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
package Vend::MakeCat;
use Cwd;
use File::Find;
use File::Copy;
use File::Basename;
use Sys::Hostname;
use Vend::Util;
require Safe;
$Safe = new Safe;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
%Conf
%Content
%Ever
%History
%IfRoot
%Commandline
%Postprocess
%Prefix
%Window
$Force
$Safe
add_catalog
addhistory
applicable_directive
can_do_suid
check_root_execute
compare_file
conf_parse_http
copy_current_to_dir
copy_dir
description
debug
directory_process
do_msg
error_message
find_inet_info
findexe
findfiles
get_id
get_ids
get_rename
history
inet_host
inet_port
install_file
label
prefix
pretty
prompt
read_additional
readconfig
sethistory
strip_na
strip_trailing_slash
substitute
sum_it
unique_ary
validate
);
use strict;
use vars qw($Safe $Force $Error $History $VERSION);
$Safe->share(qw/%Conf %Ever &debug/);
use vars qw/
%Alias
%Conf
%Content
%Commandline
%Ever
%History
%IfRoot
%Postprocess
%Special_sub
%Prefix
%Window
/;
$VERSION = substr(q$Revision: 2.10 $, 10);
$Force = 0;
$History = 0;
%Alias = (
serverconf => {
linux => '/etc/httpd/conf/httpd.conf',
},
);
my %Watch = qw/
cfg_extramysql 1
/;
my %Pretty = (
qw/
aliases Aliases
basedir BaseDir
catroot CatRoot
catuser CatUser
cgibase CgiBase
cgidir CgiDir
cgiurl CgiUrl
demotype DemoType
documentroot DocumentRoot
imagedir ImageDir
imageurl ImageUrl
interchangegroup InterchangeGroup
interchangeuser InterchangeUser
mailorderto MailOrderTo
samplehtml SampleHtml
sampleurl SampleUrl
serverconf ServerConf
servername ServerName
sharedir ShareDir
shareurl ShareUrl
vendroot VendRoot
/,
linkmode => 'Link mode',
);
my %Label = (
add_catalog => 'Add catalog to interchange.cfg',
aliases => 'Link aliases',
basedir => 'Base directory for catalogs',
catroot => 'Catalog directory',
catuser => 'Catalog user',
catalogname => 'Catalog name',
cgibase => 'CGI base URL',
cgidir => 'CGI Directory',
cgiurl => 'URL call for catalog',
demotype => 'Catalog skeleton',
documentroot => 'Document Root',
imagedir => 'Image directory',
imageurl => 'Image base URL',
interchangeuser => 'Interchange daemon username',
interchangegroup => 'Interchange daemon groupname',
linkhost => 'Link host',
linkmode => 'Link mode',
linkport => 'Link port',
mailorderto => 'Email address for orders',
permtype => 'Permission Type',
run_catalog => 'Add catalog to running server',
samplehtml => 'Catalog HTML base directory',
servconflist => 'Server config files found',
serverconf => 'Server config file',
serverlist => 'Servers in httpd.conf',
servername => 'Server name',
sharedir => 'Share Directory',
shareurl => 'Share URL',
win_addcatalog => 'Add catalog to Interchange',
win_catinfo => 'Catalog Initialization Information',
win_greeting => 'Make an Interchange Catalog',
win_servername => 'HTTP ServerName',
win_server => 'HTTP Server Information',
win_serverconf => 'HTTP Server Configuration File',
win_linkinfo => 'Link Program Information',
win_urls => 'URL and Directory Information',
);
my %Desc = (
add_catalog => <<EOF,
# To make the catalog active, you must add it to the
# interchange.cfg file. If you don't select this, then you will
# have to manually add it later.
EOF
aliases => <<EOF,
#
# Additional URL locations for the CGI program, as with CgiUrl.
# This is used when calling the catalog from more than one place,
# perhaps because your secure server is not the same name as the
# non-secure one.
#
# http://www.secure.domain/secure-bin/prog
# ^^^^^^^^^^^^^^^^
#
# We set it to the name of the catalog by default to enable the
# internal HTTP server.
#
EOF
basedir => <<EOF,
#
# DIRECTORY where the Interchange catalog directories will go.
# These are the catalog files, such as the ASCII database source,
# Interchange page files, and catalog.cfg file. Catalogs will be
# an individual subdirectory of this directory.
#
EOF
catalogname => <<EOF,
# Select a short, mnemonic name for the catalog. This will be
# used to set the defaults for naming the catalog, executable,
# and directory, so you will have to type in this name
# frequently.
#
# NOTE: This will be the name of 'vlink' or 'tlink', the link CGI
# program. Depending on your CGI setup, it may also have
# the extension .cgi added.
#
# Only the characters [-a-zA-Z0-9_] are allowed, and it is
# strongly suggested that the catalog name be all lower case.
#
# If you are doing the demo for the first time, you might use
# "foundation".
EOF
catroot => <<EOF,
# Where the Interchange files for this catalog will go, pages,
# products, config and all. This should not be in HTML document
# space! Usually a 'catalogs' directory below your home directory
# works well. Remember, you will want a test catalog and an
# online catalog.
EOF
catuser => <<EOF,
#
# The user name the catalog will be owned by.
#
EOF
cgibase => <<EOF,
#
# The URL-style location of the normal CGI directory.
# Only used to set the default for the CgiUrl setting.
#
# http://www.virtual.com/cgi-bin/prog
# ^^^^^^^^
#
# If you have no CGI-bin directory, (your CGI programs end
# in .cgi), leave this blank.
#
EOF
cgidir => <<EOF,
# The location of the normal CGI directory. This is a
# file path, not a script alias.
#
# If all of your CGI programs must end in .cgi, this is
# should be the same as your HTML directory.
#
EOF
cgiurl => <<EOF,
# The URL location of the CGI program, without the http://
# or server name.
#
# http://www.virtual.com/cgi-bin/prog
# ^^^^^^^^^^^^^
#
# http://www.virtual.com/program.cgi
# ^^^^^^^^^^^^
#
EOF
demotype => <<EOF,
# The type of demo catalog to use. The standard one distributed is:
#
# foundation
#
# If you have defined your own custom template catalog,
# you can enter its name.
#
# If you are new to Interchange, use "foundation" to start with.
EOF
documentroot => <<EOF,
# The base directory for HTML for this (possibly virtual) domain.
# This is a directory path name, not a URL -- it is your HTML
# directory.
#
EOF
imagedir => <<EOF,
# Where the image files should be copied. A directory path
# name, not a URL.
#
EOF
imageurl => <<EOF,
# The URL base for the sample images. Sets the ImageDir
# directive in the catalog configuration file. This is a URL
# fragment, not a directory or file name.
#
# <IMG SRC="/foundation/images/icon.gif">
# ^^^^^^^^^^^^^^^^^^
#
EOF
interchangegroup => <<EOF,
# The group name the server-owned files should be set to. This is
# only important if Interchange catalogs will be owned by
# multiple users and the group to be used is not the default for
# the catalog user.
#
# Normally this is left blank.
EOF
interchangeuser => <<EOF,
# The user name the Interchange server runs under on this
# machine. This should not be the same as the user that runs the
# HTTP server (i.e. NOT nobody).
EOF
linkhost => <<EOF,
# If you are using INET mode, you need to set the host the link
# CGI will talk to.
#
# If Interchange is running on the same server as your web
# server, this should be "localhost". If the web server is on a
# different machine, it is the IP address of the machine
# Interchange is running on.
EOF
linkmode => <<EOF,
# Interchange can use either UNIX- or internet-domain sockets.
# Most ISPs would prefer UNIX mode, and it is more secure.
#
# If you already have a program there, or use mod_interchange,
# select NONE. You will then need to copy the program by hand or
# otherwise ensure its presence.
EOF
linkport => <<EOF,
# If you are using INET mode, you need to set the port the
# link CGI will talk to. The IANA standard for Interchange is
# port 7786.
EOF
mailorderto => <<EOF,
# The email address where orders for this catalog should go. To
# have a secure catalog, either this should be a local user name
# and not go over the Internet -- or use the PGP option.
#
EOF
permtype => <<EOF,
# The type of permission structure for multiple user catalogs.
#
# Select:
# M for each user in own group (with interchange user in group)
# G for all users in group of interchange user
# U for all catalogs owned by interchange user
# (should be catuser as well)
#
# M is recommended, G works for most installations.
EOF
run_catalog => <<EOF,
# You can add this catalog to the running Interchange server. You
# may not want to do this if you are using a SQL database, as you
# will not be able to monitor the database creation activity.
#
# If you don't do it, then you can restart Interchange to
# activate the new catalog.
EOF
samplehtml => <<EOF,
# Where the sample HTML files (not Interchange pages) should be
# installed. There is a difference. Usually a subdirectory of
# your HTML directory.
#
EOF
sampleurl => <<EOF,
# Our guess as to the URL to run this catalog, used for the
# client-pull screens and an informational message, not prompted for.
#
EOF
servconflist => <<EOF,
# A list of server configuration files automatically found.
# When you use history to change this, it will be reflected
# in the next field to save you entering the file name.
#
EOF
serverconf => <<EOF,
# The server configuration file, if you are running
# Apache or NCSA. Often:
# /etc/httpd/conf/httpd.conf
# /usr/local/apache/conf/httpd.conf
# /usr/local/etc/httpd/conf/httpd.conf
#
EOF
servername => <<EOF,
# The server name, something like: www.company.com
# www.company.com:8000
# www.company.com/~yourname
#
EOF
sharedir => <<EOF,
# This is a directory path name (not a URL) where the administration user
# interface images from share/ should be copied to. These will normally be
# shared by all catalogs. Often this is the same as your DocumentRoot.
#
EOF
shareurl => <<EOF,
# The URL base for the administration user interface images.
# This is a URL fragment, not an entire URL.
#
# <IMG SRC="/interchange/en_US/bg.gif">
# (leave blank)
#
# <IMG SRC="/~yourname/interchange/en_US/bg.gif">
# ^^^^^^^^^^
#
EOF
vendroot => <<EOF,
# The directory where the Interchange software is installed.
#
EOF
win_addcatalog => <<EOF,
# You should add the catalog callout to interchange.cfg, and
# optionally can add it into the running server.
EOF
win_catinfo => <<EOF,
# We need to set base template type and directory for your catalog.
EOF
win_greeting => <<EOF,
# Welcome to Interchange!
#
# You can now configure a working catalog.
#
# You can exit by selecting the "Cancel" button below, but your
# catalog will not be built until you complete the configuration.
EOF
win_linkinfo => <<EOF,
# We need to get information necessary for compiling the link
# program(s).
EOF
win_server => <<EOF,
# We need to know some basic HTTP Server configuration information.
EOF
win_serverconf => <<EOF,
# If you are using Apache or another HTTP server with the same
# type of configuration file, we can read it and set some
# defaults based on the server name you are using.
EOF
win_servername => <<EOF,
# Since you are running Apache, we can give you a choice of the
# server names defined in the httpd.conf file you selected. This
# will be used to pre-set items like DocumentRoot, ScriptAlias
# (cgi-bin), etc.
#
# If you don't see your server, pick the empty option and go to
# the next screen.
EOF
win_urls => <<EOF,
# We need to set the HTML, image, and executable paths for your
# catalog.
EOF
);
my %Validate = (
demotype => <<EOF,
The demotype skeleton directory must exist. In addition, if you
are root the files must be owned by root and not be group-
or world-writable.
EOF
);
my %Build_error = (
demotype => <<EOF,
There were errors in copying the demo files. Cannot
continue. Check to see if permissions are correct.
EOF
);
my $Wname = 'content00';
sub readconfig {
my ($file, $ref) = @_;
return undef unless $file;
return undef unless -f $file;
$ref = {} unless ref $ref;
open (INICONF, "< $file")
or die "open $file: $!\n";
local($/);
my $data = <INICONF>;
close INICONF;
my $novirt;
my %virtual;
$data =~ s/^\s*#.*//mg;
$data =~ m{(\[<)}
or $novirt = 1;
my $first = $1;
if($first eq '<') {
$data =~ s!
<catalog\s+
([^>\n]+)
\s*>\s+
([\000-\377]*?)
</catalog>!
$virtual{$1} = $2; ''!xieg;
$virtual{'_base'} = $data;
}
else {
my %recognize = ( base => '_base' );
my @lines = grep /\S/, split /\n/, $data;
my $handle;
for(@lines) {
if(/^\[(.*?)\]\s*$/) {
my $hh = $1;
if($hh =~ /^catalog\s+(\S+)/) {
$handle = $1;
}
elsif($recognize{$hh}) {
$handle = $recognize{$hh};
}
else {
undef $handle;
}
$virtual{$handle} = '' if ! $virtual{$handle};
next;
}
next unless $handle;
next unless /\S/;
$virtual{$handle} .= $_;
}
}
my $out = {};
foreach my $hk (keys %virtual) {
my $ref = $out->{$hk} = {};
my @lines = grep /\S/, split /\n/, $virtual{$hk};
for(@lines) {
s/^\s+//;
s/\s+$//;
my ($k, $v) = split /\s*=\s*/, $_, 2;
$ref->{$k} = $v;
}
}
return $out;
}
sub read_additional {
my ($file) = @_;
if (! $file) {
$file = "$Conf{vendroot}/$Conf{demotype}/config/additional_fields";
return undef unless -f $file;
}
my $help = $file;
$help =~ s/_fields$/_help/ or undef $help;
my $data;
SPLIT: {
local ($/);
open ADDLFIELDS, "< $file"
or return undef;
$data = <ADDLFIELDS>;
close ADDLFIELDS;
}
HELP: {
local($/) = "";
last HELP unless open ADDLHELP, "< $help";
while(<ADDLHELP>) {
s/^[.\t ]+$//mg;
my ($k, $v) = split /\n/, $_, 2;
$Desc{lc $k} = $v;
}
close ADDLHELP;
}
my @chunks;
if($data =~ /^\s*</) {
@chunks = read_common_config($data);
return read_additional_new(@chunks);
}
else {
@chunks = split /\n\n+/, $data;
return read_additional_old(@chunks);
}
}
sub read_additional_old {
my (@chunks) = @_;
my @addl_windows;
my %label;
my $winref;
for(@chunks) {
my $noprompt = '';
my $grp;
my $realgrp;
my $wid;
my $cref = {};
s/\s+$//;
my ($var, $prompt, $default) = split /\n/, $_, 3;
($var, $realgrp, $wid) = split /\t/, $var;
$cref->{widget} = $wid if $wid;
my $label;
($prompt, $label) = split /\t/, $prompt, 2;
my $subcode;
my $mainparam;
if($var =~ s/{\s*([A-Z0-9]+)(\s*\S.*?)?\s*}\s*//) {
$mainparam = lc $1;
my $test = $2;
$test =~ s/'?__MVC_([A-Z0-9]+)__'?/\$Conf{\L$1}/g;
$subcode = <<EOF;
sub {
my \$status;
if(\$Conf{$mainparam} $test) {
\$status = 1;
}
else {
\$status = 0;
}
return \$status;
}
EOF
my $sub = eval $subcode;
if($@) {
undef $sub;
}
$cref->{conditional} = $sub;
}
$var =~ s/\s+//g;
$var =~ s:^!::
and $noprompt = 1;
$var =~ s/\W+//g;
$var = lc $var;
debug("conditional code: $subcode") if $Watch{$var};
$cref->{help} = description($var);
$cref->{group} ||= $realgrp;
$grp = $cref->{group} || $var;
if(! $var and $cref->{group}) {
$Window{$cref->{group}} ||= { };
$Window{$cref->{group}}->{banner} = $label || $prompt;
$Window{$cref->{group}}->{help} =
$Window{$cref->{group}}->{message} = description($cref->{group});
push @addl_windows, $cref->{group};
next;
}
elsif($grp ne $var) {
if (! $Window{$grp}) {
$Window{$grp} = { };
push @addl_windows, $grp;
}
elsif($mainparam) {
$Window{$grp}{conditional} = $cref->{conditional}
if ! $Window{$grp}{conditional};
}
$Window{$grp}{contents} = [] if ! $Window{$grp}{contents};
push @{$Window{$grp}{contents}}, $var;
}
else {
push @addl_windows, $var;
}
my (@history) = split /\t/, $default;
$default = $Conf{$var} || $history[0] || '';
if($label =~ /\S/) {
$cref->{banner} = $prompt;
$cref->{label} = $label;
}
else {
$cref->{label} = $prompt;
}
my $presubcode;
if($default =~ s/__MVC_([A-Z0-9]+)__/\$Conf{\L$1}/g) {
$default =~ s/\@/\\\@/g;
my $presubcode = qq{
sub {
return qq[$default]
}
};
my $presub = eval $presubcode;
if($@) {
debug("error evaling prefix sub for $var: $presubcode");
}
$cref->{prefix} = $presub;
$cref->{prefix_source} = $presubcode;
}
else {
$cref->{prefix} = $default;
}
$cref->{options} = \@history;
if ($noprompt) {
if($cref->{conditional}) {
my $snippet = <<EOF;
\$Conf{$var} = q{$default} if \$status;
return \$status;
}
EOF
# Appease vi {
$subcode =~ s/\s*return .*\s+}\s*$/$snippet/;
$cref->{conditional} = eval $subcode;
$cref->{conditional_source} = $subcode;
}
else {
$Conf{$var} = substitute($default);
$cref->{conditional} = sub { 0 };
}
}
if($mainparam || $cref->{group}) {
my $winref;
if($cref->{group}) {
$winref = $Window{$cref->{group}};
}
else {
$winref = $Content{$mainparam};
$winref->{additional} ||= [];
push @{$winref->{additional}}, $var;
}
$winref->{override} ||= {};
$winref->{override}{$var} = $cref;
$Content{$var} = $cref unless $Content{$var};
}
elsif ($Content{$var}) {
die("generated duplicate param for $var with no group or mainparam.\n");
debug("generated duplicate param for $var with no group or mainparam.\n");
}
else {
$Content{$var} = $cref;
}
#debug( "ref for $var: " . ::uneval($cref));
}
close ADDLFIELDS;
#debug("read_additional: returning: " . join ",", @addl_windows);
my %seen;
# Multiple conditions may define them more than once
@addl_windows = grep !$seen{$_}++, @addl_windows;;
return @addl_windows;
}
sub read_additional_new {
my ($help, @chunks) = @_;
my $winref;
my @addl_windows;
foreach my $cref (@chunks) {
my $grp;
my $subcode;
my $mainparam;
my $var;
my $default;
my $cond_code;
if(! ref $cref) {
# Bad chunk
next;
}
$cref->{_additional} = 1;
if($cond_code = $cref->{conditional}) {
delete $cref->{conditional};
if($cond_code =~ /^sub\s+{.*}\s*$/s) {
$subcode = $cond_code;
}
else {
$cond_code =~ m{^[A-Z][A-Z0-9]+$}
and $cond_code = "\U__MVC_${cond_code}__";
$cond_code =~ m{__MVC_([A-Z0-9]+)__}
and $mainparam = lc $1;
$cond_code =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1}
{'$Conf{' . lc $2 . '}' }eg;
# Appease vi }
$subcode = <<EOF;
sub {
my \$status;
if($cond_code) {
\$status = 1;
}
else {
\$status = 0;
}
return \$status;
}
EOF
}
}
if($subcode) {
my $sub = eval $subcode;
if($@) {
debug("Problem evaluating sub: $subcode");
undef $sub;
}
$cref->{conditional} = $sub;
}
for my $code (qw/callback/) {
my $cb = $cref->{$code}
or next;
if($cb =~ /^\s*sub\s+{/) {
# Appease vi }
local($SIG{__DIE__});
$cref->{$code} = eval $cb;
$cref->{"${code}_source"} = $cb;
}
elsif($cb =~ /^\s*\[.*\]\s*$/s) {
$cref->{$code} = eval($cb);
$cref->{"${code}_source"} = $cb;
}
elsif($cb =~ /[a-z]/) {
my @items = Text::ParseWords::shellwords($cref->{$code});
@items = map { lc $_ } @items;
$cref->{$code} = \@items;
$cref->{"${code}_source"} = $cb;
}
}
for my $code (qw/options history/) {
my $cb = $cref->{$code}
or next;
if($cb =~ /^\s*sub\s+{.*}\s*$/s) {
local($SIG{__DIE__});
$cref->{$code} = eval $cb;
$cref->{"${code}_source"} = $cb;
}
elsif($cb =~ /^\s*\[.*\]\s*$/s) {
$cref->{$code} = eval($cb);
$cref->{"${code}_source"} = $cb;
}
elsif($cb =~ /[a-z]/) {
my @items = Text::ParseWords::shellwords($cref->{$code});
$cref->{$code} = \@items;
$cref->{"${code}_source"} = $cb;
}
}
for my $code (qw/check_routine/) {
my $cb = $cref->{$code}
or next;
if($cb =~ /^\s*sub\s+{/) {
# Appease vi }
$cref->{$code} = eval $cb;
$cref->{"${code}_source"} = $cb;
}
else {
undef $cref->{$code};
}
}
$var = $cref->{name} || $Wname++;
$var =~ s/\s+//g;
$var =~ s/\W+//g;
$cref->{name} = $var = lc $var;
$::Subcode{$var} = $subcode;
debug("conditional code: $subcode") if $Watch{$var};
$grp = $cref->{group} || $var;
if($cref->{_window}) {
if(my $wref = $Window{$var}) {
for(keys %$wref) {
$cref->{$_} = $wref->{$_}
unless defined $cref->{$_};
}
}
$cref->{help} ||= description($var);
$cref->{message} ||= $cref->{help};
$cref->{banner} ||= $cref->{label};
push @addl_windows, $var;
$Window{$var} = $cref;
next;
}
elsif($grp ne $var) {
if (! $Window{$grp}) {
$Window{$grp} = { };
push @addl_windows, $grp;
}
elsif($mainparam) {
$Window{$grp}{conditional} = $cref->{conditional}
if ! $Window{$grp}{conditional};
}
$Window{$grp}{contents} = [] if ! $Window{$grp}{contents};
push @{$Window{$grp}{contents}}, $var;
}
else {
push @addl_windows, $var;
}
if(! $cref->{default} and ref $cref->{history} eq 'ARRAY') {
$cref->{default} = $cref->{history}[0];
}
$cref->{help} ||= description($var);
$cref->{message} ||= $cref->{help};
# Set default one of three ways
if($cref->{default}) {
$default = $cref->{default};
}
if($default =~ /\t/ and ! $cref->{history}) {
$cref->{history} = [ split /\t/, $default ];
$default =~ s/\t.*//;
$cref->{default} = $default;
}
$cref->{label} = $cref->{prompt} if ! $cref->{label};
my $presubcode;
if($cref->{default} =~ s/__MVC_([A-Z0-9]+)__/\$Conf{\L$1}/g) {
$cref->{default} =~ s/\@/\\\@/g;
my $presubcode = qq{
sub {
return qq[$cref->{default}]
}
};
my $presub = eval $presubcode;
if($@) {
debug("error evaling prefix sub for $var: $presubcode");
}
$cref->{default} = $cref->{prefix} = $presub;
$cref->{default_source} = $presubcode;
}
else {
$cref->{default} = $cref->{prefix} = $default;
}
$cref->{options} = $cref->{history} if ! $cref->{options};
if ($cref->{noprompt}) {
if($cref->{conditional}) {
# Appease vi {
my $snippet = <<EOF;
\$Conf{$var} = q{$default} if \$status;
return \$status;
}
EOF
# Appease vi {
$subcode =~ s/\s*return .*\s+}\s*$/$snippet/;
$cref->{conditional} = eval $subcode;
if($@) {
debug("Problem evaluating sub: $subcode");
}
$cref->{conditional_source} = $presubcode;
}
else {
$Conf{$var} = $default;
$cref->{conditional} = sub { 0 };
}
}
if($cref->{always_set}) {
$Conf{$var} = substitute($default);
}
if($mainparam || $cref->{group}) {
my $winref;
if($cref->{group}) {
$winref = $Window{$cref->{group}};
}
else {
$winref = $Content{$mainparam};
$winref->{additional} ||= [];
push @{$winref->{additional}}, $var;
}
$winref->{override} ||= {};
$winref->{override}{$var} = $cref;
}
elsif ($Content{$var}) {
debug("generated duplicate param for $var with no group or mainparam.");
die("generated duplicate param for $var with no group or mainparam.");
}
else {
$Content{$var} = $cref;
push @addl_windows, $var;
}
#debug( "ref for $var: " . ::uneval($cref));
}
my %seen;
# Multiple conditions may define them more than once
@addl_windows = grep !$seen{$_}++, @addl_windows;;
debug("read_additional returning windows: " . join ",", @addl_windows);
#debug("Here is the whole shebang:\n" . uneval(\%Window) . "\ncontent:\n" . uneval(\%Content));
return @addl_windows;
}
sub read_common_config {
my $data = shift;
#debug("read_common_config called with data=$data");
my @lines = split /\n/, $data;
my $prev = '';
my $waiting;
my @out;
my $out = \@out;
my $wref;
my $cref;
my $type;
for(@lines) {
# Strip CR, we hope
s/\s+$//;
# Handle continued lines
if(s/\\$//) {
$prev .= $_;
next;
}
elsif($waiting) {
if($_ eq $waiting) {
undef $waiting;
$_ = $prev;
$prev = '';
s/\s+$//;
}
else {
$prev .= "$_\n";
next;
}
}
elsif($prev) {
$_ = "$prev$_";
$prev = '';
}
if (s/<<(\w+)$//) {
$waiting = $1;
$prev .= $_;
next;
}
next unless /\S/;
next if /^\s*#/;
if(m{
^ \s* <
(\w+)
(?:\s+(\w[-\w]*\w))?
\s*>\s*
}x)
{
$type = lc $1;
my $name = $2 || undef;
if($name) {
$name = lc $name;
$name =~ tr/-/_/;
}
if(defined $cref and $cref->{_window} and $type ne 'window') {
$wref = $cref;
$out = $wref->{content_array} ||= [];
}
else {
push @$out, $cref if $cref;
}
$cref = { "_$type" => 1, name => $name };
next;
}
elsif (m{^\s*</(\w[-\w]+\w)\s*>\s*}) {
my $ender = lc $1;
$ender =~ tr/-/_/;
if(! $cref) {
push @out, $wref if $wref;
$out = \@out;
undef $type;
undef $wref;
undef $cref;
}
elsif($ender eq $type) {
if($type eq 'window') {
push @out, ($wref || $cref);
undef $cref;
undef $wref;
$out = \@out;
}
else {
push @$out, $cref;
undef $cref;
}
}
else {
die errmsg("Syntax error in config input: %s", $_);
}
next;
}
s/^\s*(\w[-\w]*\w)(\s+|$)//
or do {
die "Problem reading config reference type=$type: $_\n";
};
my $parm = lc $1;
$cref ||= {};
$parm =~ tr/-/_/;
$cref->{$parm} = $_;
}
push @out, $cref if $cref;
my @extra;
for my $ref (@out) {
if($ref->{content_array} and $ref->{_window}) {
for (@{delete $ref->{content_array}}) {
$_->{name} ||= $Wname++;
debug("popping $_->{name} from $ref->{name} content array");
$_->{group} = $ref->{name};
push @extra, $_;
}
}
}
push @out, @extra;
#debug("read_common_config: " . uneval(\@out) );
return @out;
}
sub read_commands {
my ($file, $wref) = @_;
my @data;
my @files;
my $pre_post;
if(! $file) {
@files = (
"$Conf{vendroot}/$Conf{demotype}/config/precopy_commands",
"$Conf{vendroot}/$Conf{demotype}/config/postcopy_commands",
);
$pre_post = 1;
}
else {
@files = ($file);
$wref = {} unless $wref;
}
for (my $i = 0; $i < @files; $i++) {
my $fn = $files[$i];
next if ! $fn;
next if ! -f $fn;
open CMDFILE, "< $fn"
or do {
my $msg = errmsg(
"Cannot %s commands file %s: %s",
errmsg('open'),
$fn,
$!,
);
die "$msg\n";
};
local ($/);
$data[$i] = <CMDFILE>;
close CMDFILE
or do {
my $msg = errmsg(
"Cannot %s commands file %s: %s",
errmsg('close'),
$fn,
$!,
);
die "$msg\n";
};
}
my $cmd_num = "cmd000";
return undef unless @data;
foreach my $block (@data) {
my $root_msg = $> == 0 ? <<EOF : '';
Because you are root, you should be very careful
what commands you run. If you are unsure about the
ownership of any files, or of what the effects might
be, please uncheck the box next to the command.
EOF
if($pre_post eq '1') {
if(! $Window{precopy_commands}) {
$Window{precopy_commands} = {
contents => [],
conditional => 0,
message => 'Resolving catalog initialization commands',
};
}
$wref = $Window{precopy_commands};
$pre_post = 2;
}
elsif ($pre_post == 2) {
if(! $Window{postcopy_commands}) {
$Window{postcopy_commands} = {
contents => [],
banner => 'Resolving catalog finalization commands',
};
}
$wref = $Window{postcopy_commands};
$pre_post = 3;
}
next unless $block;
my @cmds;
if($block =~ /^\s*</) {
@cmds = read_common_config($block);
}
else {
@cmds = split /\n\n+/, $block;
}
foreach my $cmd (@cmds) {
my $cref;
my $unprompted;
my $subcode;
my $mainparam;
my ($command, $prompt);
if(ref $cmd) {
$cref = $cmd;
$cmd = '';
}
else {
$cmd = substitute($cmd);
$cmd =~ s/\\\n//g;
$cref = {};
my $prompt;
($command, $prompt) = split /\n/, $cmd, 2;
if($prompt =~ s/^\s*(\w+\s*=[^\n]*|{\s*\w+\s*=.*})\s*\n//s) {
my $extra = $1;
#debug("Found command mods: $extra");
my $ref = get_option_hash($extra);
#debug("Command mods: " . uneval($ref));
if (ref $ref) {
for (keys %$ref) {
$cref->{$_} = $ref->{$_};
}
}
else {
warn "Unsuccessful command option parse: $extra\n";
}
}
$cref->{help} = $prompt if ! $cref->{help};
}
if($cref->{window_indicator}) {
$wref ||= $Window{$cref->{name}};
for(keys %$cref) {
$wref->{$_} = $cref->{$_};
}
next;
}
$cref->{widget} = 'yesno' if ! $cref->{widget};
$command = $cref->{command} if ! $command;
$command =~ s/^\s+//;
$command =~ s/\s+$//;
$command =~ s/^!// and $> != 0 and $cref->{unprompted} = 1;
delete $wref->{conditional}
if $wref->{conditional} eq '0'
and $pre_post;
if($command =~ s/{\s*([A-Z0-9]+)(\s*\S.*?)?\s*}\s*//) {
$mainparam = lc $1;
my $test = $2;
$test =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1}
{'\$Conf{' . lc $2 . '}' }eg;
$subcode = <<EOF;
sub {
my \$status;
#debug("conditional checking param=$mainparam testing=$test Value=\$Conf{$mainparam}");
if(\$Conf{$mainparam} $test) {
\$status = 1;
}
else {
\$status = 0;
}
#debug("conditional routine returning \$status");
return \$status;
}
EOF
}
elsif ( $cref->{conditional} ) {
$cref->{conditional} =~ s/^[A-Z0-9a-z]+$/__MVC_\U${1}__/;
$cref->{conditional} =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1}
{'\$Conf{' . lc $2 . '}' }eg;
# Make vi happy: } }
$subcode = delete $cref->{conditional};
}
#debug("read_commands: sub=$subcode");
if($subcode) {
$subcode = "sub {\n" . $cref->{conditional} . "}"
unless $subcode =~ /^\s*sub\s+{/;
my $sub = eval $subcode;
if($@) {
debug("read_commands: Problem evaluating sub: $subcode");
undef $sub;
}
$cref->{conditional} = $sub;
}
$cref->{command} = $command;
$cref->{label} = $command if ! $cref->{label};
$cref->{name} = $cmd_num++ unless $cref->{name};
my $name = $cref->{name};
$Content{$name} = $cref;
if(my $gname = $cref->{group}) {
$Window{$gname}->{contents} ||= [];
push @{$Window{$gname}->{contents}}, $name;
}
else {
push @{$wref->{contents}}, $name;
}
}
}
if($pre_post) {
return ($Window{precopy_commands}, $Window{postcopy_commands});
}
else {
return $wref;
}
}
# Validate a field against:
#
# check_regex -- a regular expression which must succeeed
# check_blank -- Just needs a non-blank value
# check_routine -- a subroutine which can return -1, 0, 1
# check_message -- a template (from errmsg) which can be used
#
# If the return value is -1, then the error message is assumed
# to have been handled by the check_routine and is not returned.
#
sub validate {
my ($val, $parm) = @_;
my $thing = $Content{$parm};
if(! $parm or ! $thing) {
return (0, errmsg('blank'));
}
my $status;
my $message = $thing->{check_message};
my $errmsg;
if($thing->{check_regex}) {
$errmsg = errmsg('blank');
$status = length($val) ? 1 : 0;
}
elsif($thing->{check_regex}) {
my $regex = qr/$thing->{check_regex}/;
$status = $val =~ $regex;
}
elsif($thing->{check_routine}) {
($status, $errmsg) = $thing->{check_routine}->($val, $parm);
}
else {
$status = 1;
}
## This allows directly returning error and no confirm screen
return $status if abs($status);
$message = "%s (value '%s'): failed validation"
if ! $message;
my $lab = label($parm) || $parm;
$message = errmsg($message, $lab, $val, $parm);
return($status, $message);
}
sub prefix {
my ($parm, $nodefault, $override) = @_;
$parm = lc $parm;
if($Alias{$parm} and $Conf{$parm}) {
$Conf{$parm} = $Alias{$parm}{$Conf{$parm}};
}
return $Conf{$parm} if $Conf{$parm};
return $ENV{"MVC_\U$parm"} if $ENV{"MVC_\U$parm"};
return undef if $nodefault;
my $thing = $Content{$parm}{prefix} || $Prefix{$parm};
if(ref $thing eq 'CODE') {
return $thing->();
}
elsif(ref $thing eq 'ARRAY') {
return $thing->[0];
}
else {
return $thing;
}
}
%Special_sub= (
cryptpw => sub {
my $pw = shift;
return $pw if $Conf{alreadycrypt};
my @letters = ('A' .. 'Z', 'a' .. 'z');
my $salt = $letters[ int rand(scalar @letters) ];
$salt .= $letters[ int rand(scalar @letters) ];
return crypt($pw, $salt);
},
);
sub substitute {
my($parm) = @_;
if($parm !~ /^\w+$/) {
$parm =~ s/__MVC_([A-Z0-9]+)__/$Conf{lc $1}/eg;
}
elsif (defined $ENV{"MVC_$parm"}) {
$parm = $ENV{"MVC_$parm"};
}
elsif (my $sub = $Special_sub{lc $parm}) {
if(ref $sub) {
$parm = $sub->($Conf{lc $parm});
}
else {
$parm = $sub;
$parm =~ s/__MVC_([A-Z0-9]+)__/$Conf{lc $1}/eg;
}
}
else {
$parm = $Conf{lc $parm};
}
$parm = '' unless defined $parm;
return $parm;
}
sub sum_it {
my ($file) = @_;
open(IT, "<$file")
or return undef;
my $data = '';
$data .= $_ while (<IT>);
close IT;
return unpack("%32c*", $data);
}
sub strip_na {
my $val = shift;
return '' if lc($val) eq 'n/a';
return $val;
}
sub directory_process {
my $dir = shift;
$dir =~ s:[/\s]+$::;
if($Conf{catuser} and $dir =~ /^~/) {
my $userdir = ( getpwnam( $Conf{catuser} ) )[7];
$dir =~ s/^~/$userdir/ if $userdir;
}
return $dir;
}
sub strip_trailing_slash {
my $url = shift;
$url =~ s:[/\s]+$::;
return $url;
}
sub inet_host {
return scalar find_inet_info('h');
}
sub inet_port {
return scalar find_inet_info('p');
}
sub find_inet_info {
my $type = shift;
my (@hosts);
my (@ports);
my $prog = "$Conf{relocate}$Conf{vendroot}/src/tlink";
my $the_one = sum_it($prog);
my $defport = '7786';
my $defhost = 'localhost';
my @poss = glob("$Conf{relocate}$Conf{vendroot}/src/tlink.*.*");
for (@poss) {
my $name = $_;
/tlink\.(.*)\.(\d+)$/
or next;
my ($h, $p) = ($1, $2);
push @hosts, $h;
push @ports, $p;
my $one = sum_it($_);
next unless $one eq $the_one;
$defhost = $h;
$defport = $p;
}
if(! $type) {
my %seen;
@ports = grep !$seen{$_}++, @ports;
%seen = ();
@hosts = grep !$seen{$_}++, @hosts;
return (\@hosts, \@ports);
}
elsif ($type =~ /^h/i) {
return $defhost;
}
elsif ($type =~ /^p/i) {
return $defport;
}
}
sub applicable_directive {
my ($direc, $routine) = @_;
$direc = lc($direc);
if($routine) {
return undef if ! $routine->($direc);
}
return $direc if ! defined $IfRoot{$direc};
return undef if $Conf{asroot} xor $IfRoot{$direc};
return $direc;
}
sub findexe {
my($exe) = @_;
my($dir,$path) = ('', $ENV{PATH});
$path =~ s/\(\)//g;
$path =~ s/\s+/ /g;
my(@dirs) = split /[\s:]+/, $path;
foreach $dir (@dirs) {
return "$dir/$exe" if -x "$dir/$exe";
}
return '';
}
sub findfiles {
my($file) = @_;
return undef if $^O =~ /win32/i;
my $cmd;
my @files;
if($cmd = findexe('locate')) {
@files = `locate \\*/$file`;
}
else {
@files = `find / -name $file -print 2>/dev/null`;
}
return undef unless @files;
chomp @files;
return @files;
}
sub pretty {
my($parm) = @_;
return defined $Pretty{lc $parm} ? $Pretty{lc $parm} : $parm;
}
sub history {
my $parm = shift;
$parm = lc $parm;
return unless defined $History{$parm};
my @things = $History{$parm}->(@_);
return wantarray ? @things : \@things;
}
sub error_message {
my($parm) = @_;
$parm = lc $parm;
return defined $Validate{$parm} ? $Validate{$parm} : '';
}
sub label {
my($parm) = @_;
return defined $Label{lc $parm} ? $Label{lc $parm} : '';
}
sub description {
my($parm) = @_;
return defined $Desc{lc $parm} ? $Desc{lc $parm} : '';
}
sub can_do_suid {
return 0 if $^O =~ /win32/i;
my $file = "tmp$$.fil";
my $status;
open(TEMPFILE,">$file");
close TEMPFILE;
eval { chmod 04755, $file; $@ = ''};
$status = $@ ? 0 : 1;
unlink $file;
return $status;
}
sub get_id {
return 'everybody' if $^O =~ /win32/i;
my $file = -f "$Global::VendRoot/error.log"
? "$Global::VendRoot/error.log" : '';
return '' unless $file;
my ($name);
my($uid) = (stat($file))[4];
$name = (getpwuid($uid))[0];
return $name;
}
sub get_ids {
return ('everybody', 'nogroup') if $^O =~ /win32/i;
my $file = "tmp$$.fil";
my ($name, $group);
open(TEMPFILE,">$file");
close TEMPFILE;
my($uid,$gid) = (stat($file))[4,5];
unlink $file;
$name = (getpwuid($uid))[0];
$group = (getgrgid($gid))[0];
return ($name,$group);
}
sub get_rename {
my ($bn, $extra) = @_;
$extra = '~' unless $extra;
$bn =~ s:(.*/)::;
my $dn = $1;
return $dn . "/.$extra." . $bn;
}
sub compare_file {
my($first,$second) = @_;
return 0 unless -f $first && -f $second;
return 0 unless -s $first == -s $second;
local $/;
open(FIRST, "< $first") or return undef;
open(SECOND, "< $second") or (close FIRST and return undef);
binmode(FIRST);
binmode(SECOND);
$first = '';
$second = '';
while($first eq $second) {
read(FIRST, $first, 1024);
read(SECOND, $second, 1024);
last if length($first) < 1024;
}
close FIRST;
close SECOND;
$first eq $second;
}
sub set_owner {
return unless $> == 0;
my($file) = @_;
resolve_owner()
unless $Conf{interchangeuid};
my ($user, $group) = ($Conf{interchangeuid}, $Conf{interchangegid});
die errmsg("Can't find info: %s", 'interchangeuid')
unless $Conf{interchangeuid};
if($Conf{permtype} =~ /^m/i) {
$user = $Conf{catuseruid};
$group = $Conf{catusergid};
}
elsif($Conf{permtype} =~ /^g/i) {
$group = $Conf{catusergid};
}
chown($user, $group, $file)
or die errmsg(
"Couldn't set ownership to UID=%s GID=%s for %s: %s",
$user,
$group,
$file,
$!,
);
}
sub install_file {
my ($srcdir, $targdir, $filename, $opt) = @_;
$opt = {} unless $opt;
my $save_umask;
if($opt->{umask} ) {
$save_umask = umask $opt->{umask};
local($SIG{__DIE__}) = sub { umask $save_umask; warn @_; exit 1 };
}
my $scale;
if($scale = $opt->{scale_call}) {
$scale->( 'start', $opt->{scale}, $opt->{message});
}
if (ref $srcdir) {
$opt = $srcdir;
$srcdir = $opt->{Source} || die "Source dir for install_file not set.\n";
$targdir = $opt->{Target} || die "Target dir for install_file not set.\n";
$filename = $opt->{Filename} || die "File name for install_file not set.\n";
}
my $srcfile = $srcdir . '/' . $filename;
my $targfile = $targdir . '/' . $filename;
my $mkdir = File::Basename::dirname($targfile);
my $extra;
my $perms;
if(! -d $mkdir) {
File::Path::mkpath($mkdir, undef, $opt->{dmode} || 0777)
or die "Couldn't make directory $mkdir: $!\n";
chmod($opt->{dmode}, $mkdir) if $opt->{dmode};
set_owner($mkdir);
}
if (! -f $srcfile) {
die "Source file $srcfile missing.\n";
}
elsif (
$opt->{perm_hash}
and $opt->{perm_hash}->{$filename}
)
{
$perms = $opt->{perm_hash}->{$filename};
}
elsif ($opt->{fmode}) {
$perms = $opt->{fmode};
}
elsif ( $opt->{Perms} =~ /^(m|g)/i ) {
$perms = (stat(_))[2] | 0660;
}
elsif ( $opt->{Perms} =~ /^u/i ) {
$perms = (stat(_))[2] | 0600;
}
else {
$perms = (stat(_))[2] & 0777;
}
if( ! $Global::Win32 and -f $targfile and ! compare_file($srcfile, $targfile) ) {
open (GETVER, "< $targfile")
or die "Couldn't read $targfile for version update: $!\n";
while(<GETVER>) {
/VERSION\s+=.*?\s+([\d.]+)/ or next;
$extra = $1;
$extra =~ tr/0-9//cd;
last;
}
$extra = '~' unless $extra;
my $rename = get_rename($targfile, $extra);
while (-f $rename ) {
$extra .= '~';
$rename = get_rename($targfile, $extra);
}
rename $targfile, $rename
or die "Couldn't rename $targfile to $rename: $!\n";
}
File::Copy::copy($srcfile, $targfile)
or die "Copy of $srcfile to $targfile failed: $!\n";
if($opt->{Substitute}) {
my $bak = "$targfile.mv";
rename $targfile, $bak;
open(SOURCE, "< $bak")
or die errmsg("%s %s: %s\n", errmsg("open"), $bak, $!);
open(TARGET, ">$targfile")
or die errmsg("%s %s: %s\n", errmsg("create"), $bak, $!);
local($/) = undef;
my $page = <SOURCE>; close SOURCE;
$page =~ s/^#>>(.*)(__MVR_(\w+)__.*)\n\1.*/#>>$1$2/mg;
$page =~ s/^#>>(.*__MVR_(\w+)__.*)/#>>$1\n$1/mg;
1 while $page =~ s/^([^#].*)__MVR_(.*)/$1__MVC_$2/mg;
$page =~ s/__MV[CS]_([A-Z0-9]+)__/$opt->{Substitute}{lc $1}/g;
print TARGET $page or die "print $targfile: $!\n";
close TARGET or die "close $targfile: $!\n";
unlink $bak or die "unlink $bak: $!\n";
}
chmod $perms, $targfile;
$scale->('end') if $scale;
umask $save_umask if $save_umask;
return 1;
}
sub debug {
for(@_) {
print DEBUG "$_\n";
}
return;
}
sub copy_current_to_dir {
my($target_dir, $exclude_pattern) = @_;
return copy_dir('.', $target_dir, $exclude_pattern);
}
sub copy_dir {
my($source_dir, $target_dir, $exclude_pattern, $opt) = @_;
return undef unless -d $source_dir;
$opt = {} unless $opt;
my $scale;
if($scale = $opt->{scale_call}) {
$scale->('start', $opt->{scale}, $opt->{message});
}
my $orig_dir;
if($source_dir ne '.') {
$orig_dir = cwd();
chdir $source_dir or die "chdir: $!\n";
}
my @files;
my $wanted = sub {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s:^\./::;
return if $exclude_pattern and $name =~ m{$exclude_pattern}o;
push (@files, $name);
};
File::Find::find($wanted, '.');
# also exclude directories that match $exclude_pattern
@files = grep !m{$exclude_pattern}o, @files if $exclude_pattern;
eval {
for(@files) {
install_file('.', $target_dir, $_, $opt);
}
};
my $msg = $@;
chdir $orig_dir if $orig_dir;
die "$msg" if $msg;
return 1;
}
use vars q!$Prompt_sub!;
my $History_add;
my $History_set;
my $term;
eval {
require Term::ReadLine;
import Term::ReadLine;
$term = new Term::ReadLine 'Interchange Configuration';
die "No Term::ReadLine" unless defined $term;
readline::rl_set('CompleteAddsuffix', 'Off');
readline::rl_set('TcshCompleteMode', 'On');
$Prompt_sub = sub {
my ($prompt, $default) = @_;
if($Force) {
print "$prompt SET TO --> $default\n";
return $default;
}
$prompt =~ s/^\s*(\n+)/print $1/ge;
$prompt =~ s/\n+//g;
readline::rl_bind('C-x', 'catch-cancel');
readline::rl_bind('C-b', 'catch-backward');
readline::rl_bind('C-y', 'catch-help');
readline::rl_bind('C-f', 'catch-forward');
if(! $Conf{vi_edit_mode}) {
readline::rl_bind('"\M-\OP"', 'catch-help');
readline::rl_bind('"\M-[20"', 'catch-backward');
readline::rl_bind('"\M-[21"', 'catch-forward');
#readline::rl_bind('"\M-[1"', 'catch-cancel');
readline::rl_bind('"\M-[5"', 'catch-backward');
readline::rl_bind('"\M-[6"', 'catch-forward');
}
my $out = $term->readline($prompt, $default);
return "\cB" if ! defined $out;
return $out;
};
$History_add = sub {
my ($line) = @_;
$term->addhistory($line)
if $line =~ /\S/;
};
$History_set = sub {
$term->SetHistory(@_);
};
$History = 1;
};
sub prompt {
return &$Prompt_sub(@_)
if defined $Prompt_sub;
my($prompt) = shift || '? ';
my($default) = shift;
if($Force) {
print "$prompt SET TO --> $default\n";
return $default;
}
my($ans);
print $prompt;
print "[$default] " if $default;
local ($/) = "\n";
chomp($ans = <STDIN>);
length($ans) ? $ans : $default;
}
sub addhistory {
return '' unless defined $History_add;
return $History_add->(@_);
}
sub sethistory {
return '' unless defined $History_set;
return $History_set->(@_);
}
sub do_msg {
my ($msg, $size) = @_;
$size = 60 unless defined $size;
my $len = length $msg;
return "$msg.." if ($len + 2) >= $size;
$msg .= '.' x ($size - $len);
return $msg;
}
sub add_catalog {
my ($file, $directive, $configname, $value) = @_;
if(! $file) {
$file = "$Conf{relocate}$Global::ConfigFile";
}
$configname = $Conf{catalogname} if ! $configname;
$directive = 'Catalog' if ! $directive;
if (! $value) {
$value = "$Conf{catalogname} $Conf{catroot} $Conf{cgiurl}";
$value .= " $Conf{aliases}" if $Conf{aliases};
}
my ($newcfgline, $mark, @out);
my ($tmpfile) = "$file.$$";
if (-f $file) {
rename ($file, $tmpfile)
or die "Couldn't rename $file: $!\n";
}
else {
File::Copy::copy("$file.dist", $tmpfile)
or die errmsg("Couldn't find interchange.cfg");
}
open(CFG, "< $tmpfile")
or die "Couldn't open $tmpfile: $!\n";
$newcfgline = sprintf "%-19s %s\n", $directive, $value;
while(<CFG>) {
$mark = $. if /^#?\s*catalog\s+/i;
debug("\nDeleting old configuration $configname.\n") if s/^(\s*$directive\s+$configname\s+)/#$1/io;
push @out, $_;
}
close CFG;
open(NEWCFG, ">$file")
or die "\nCouldn't write $file: $!\n";
if (defined $mark) {
print NEWCFG @out[0..$mark-1];
print NEWCFG $newcfgline;
print NEWCFG @out[$mark..$#out];
}
else {
warn "\nNo $directive previously defined. Adding $configname at top.\n";
print NEWCFG $newcfgline;
print NEWCFG @out;
}
close NEWCFG || die errmsg("%s %s: %s\n", 'close', $file, $!);
unlink $tmpfile;
}
sub server_running {
local ($/);
debug("in server_running, pid file=$Global::PIDfile");
open(PID, "+< $Global::PIDfile")
or return undef;
debug("opened PID file");
if(Vend::Util::lockfile(\*PID, 1, 0)) {
debug("PID file not locked");
## Daemon not running;
close PID;
return undef;
}
my $pid = <PID>;
debug("PID=$pid");
$pid =~ /(\d+)/;
$pid = $1;
return $pid;
}
sub run_catalog {
my ($file, $directive, $configname, $value) = @_;
$Conf{relocate}
and die errmsg("Can't add catalog to running server when relocating.");
if(! $file) {
my $fn = 'restart';
$file = "$Global::RunDir/$fn";
}
$configname = $Conf{catalogname} if ! $configname;
$directive = 'Catalog' if ! $directive;
if (! $value) {
$value = "$Conf{catalogname} $Conf{catroot} $Conf{cgiurl}";
$value .= " $Conf{aliases}" if $Conf{aliases};
}
my $pid = server_running();
if(! defined $pid) {
die errmsg("Can't add %s to server: not running", $configname);
}
open(RESTART, "<+$file")
or open(RESTART, ">>$file")
or die errmsg("%s %s: %s\n", errmsg("write"), $file, $!);
Vend::Util::lockfile(\*RESTART, 1, 1)
or die errmsg("%s %s: %s\n", errmsg("lock"), $file, $!);
printf RESTART "%-19s %s\n", $directive, $value;
Vend::Util::unlockfile(\*RESTART)
or die errmsg("%s %s: %s\n", errmsg("unlock"), $file, $!);
close RESTART;
set_owner($file);
kill 'HUP', $pid;
}
my %Http_hash = (
qw(
scriptalias 1
addhandler 1
alias 1
)
);
my %Http_process = (
scriptalias => sub {
my ($junk, $val) = @_;
$val =~ s!/+$!!;
return $val;
},
);
my %Http_scalar = (
qw(
user 1
group 1
serveradmin 1
resourceconfig 1
documentroot 1
)
);
sub conf_parse_http {
my ($file) = @_;
my $virtual = {};
my $servers = {};
my $newfile;
open(HTTPDCONF, "< $file")
or do { $Error = "Can't open $file: $!"; return undef};
local($/) = undef;
my $data = <HTTPDCONF>;
close(HTTPDCONF);
if($data =~ s/^\s*resourceconfig\s+("?)(.*)\1//i) {
$newfile = $2;
}
unless(defined $newfile) {
$newfile = $file;
$newfile =~ s:[^/]+$::;
$newfile .= 'srm.conf';
}
SRMCONF: {
if (-f $newfile) {
open(HTTPDCONF, "< $newfile")
or last SRMCONF;
$data .= <HTTPDCONF>;
close(HTTPDCONF);
}
}
$data =~ s!
<virtualhost
\s+
([^>\n]+)
\s*>\s+
([\000-\377]*?)
</virtualhost>!
$virtual->{$1} = $2; ''!xieg;
$virtual->{' '} = $data;
my @data;
my $servname;
my $handle;
my $main;
foreach $handle (sort keys %$virtual) {
undef $servname;
@data = split /[\r\n]+/, $virtual->{$handle};
my $port = $handle;
$port =~ s/.*:(\d+).*/$1/ or $port = '';
@data = grep /^\s*[^#]/, @data;
for(@data) {
next unless /^\s*servername\s+(.*)/i;
$servname = $1;
$servname =~ s/\s+$//;
if(defined $servers->{$servname} and $port) {
$servname .= ":$port";
}
elsif(defined $servers->{$servname} and $port) {
$Error = "Server $servname defined twice.";
return undef;
}
$servers->{$servname} = {};
}
if($handle eq ' ') {
$servname = Sys::Hostname::hostname() unless $servname;
$servname =~ s/\s+$//;
$main = $servname;
$servers->{$servname} = {} if ! $servers->{$servname};
$servers->{$servname}{Master} = 1;
}
next unless $servname;
my $ref = $servers->{$servname};
$ref->{servername} = $servname;
foreach my $line (@data) {
$line =~ s/^\s+//;
$line =~ s/\s+$//;
my ($key, $val);
my ($directive,$param) = split /\s+/, $line, 2;
$directive = lc $directive;
if(defined $Http_hash{$directive}) {
$ref->{$directive} = {}
unless defined $ref->{$directive};
my ($key,$val) = split /\s+/, $param, 2;
$val =~ s/^\s*"// and $val =~ s/"\s*$//;
if (defined $Http_process{$directive}) {
$key = $Http_process{$directive}->('key', $key);
$val = $Http_process{$directive}->('value', $val);
}
$ref->{$directive}{$key} = $val;
}
elsif(defined $Http_scalar{$directive}) {
$param =~ s/^"// and $param =~ s/"\s*$//;
if (defined $ref->{$directive}) {
undef $ref;
$Error = "$directive defined twice in $servname, only allowed once.";
return undef;
}
if (defined $Http_process{$directive}) {
$param = $Http_process{$directive}->($param);
}
$ref->{$directive} = $param;
}
}
}
return $servers;
}
sub substitute_cryptpw {
my $pw = $Conf{cryptpw};
return unless $pw;
return if $Conf{alreadycrypt}++;
my @letters = ('A' .. 'Z', 'a' .. 'z');
my $salt = $letters[ int rand(scalar @letters) ];
$salt .= $letters[ int rand(scalar @letters) ];
$Conf{cryptpw} = crypt($pw, $salt);
}
sub unique_ary {
my %seen;
%seen = ();
return ( grep !$seen{$_}++, @_ );
}
sub resolve_owner {
my $cref = shift || \%Conf;
die errmsg("Usage: %s", "resolve_owner({ })")
unless ref $cref eq 'HASH';
return unless $> == 0 || $cref->{asroot};
my @things = qw/interchangeuser interchangegroup catuser catgroup/;
my ($icu, $icg, $catu, $catg) = @$cref{@things};
$catu = $icu if ! $catu;
# Default groups
my $icd;
my $catd;
my($icu_uid, $catu_uid, $icg_gid, $catg_gid);
$icu_uid = getpwnam($icu)
or die errmsg("User does not exist: %s\n", $icu);
$catu_uid = getpwnam($catu)
or die errmsg("User does not exist: %s\n", $catu);
if($cref->{permtype} =~ /^\s*m/i) {
$icg_gid = (getpwnam($catu))[3] if ! $icg;
$catg_gid = (getpwnam($catu))[3];
}
elsif($cref->{permtype} =~ /^\s*g/i) {
$icg_gid = (getpwnam($icu))[3] if ! $icg;
$catg_gid = (getpwnam($icu))[3];
}
else {
$icg_gid = (getpwnam($catu))[3] if ! $icg;
$catg_gid = (getpwnam($catu))[3];
}
$icg_gid = (getpwnam($icu))[3] if ! $icg_gid;
$catg_gid = (getpwnam($catu))[3] if ! $catg_gid;
@$cref{qw/
interchangeuid
interchangegid
catuid
catgid
/} = ($icu_uid, $icg_gid, $catu_uid, $catg_gid);
return $cref;
}
sub hammer_symlinks {
my $dir = shift;
File::Find::find(
sub {
return if ! -l $_;
unlink $_
or die "couldn't unlink $File::Find::name: $!\n";
},
$dir,
);
return 1;
}
sub check_root_execute {
my $dir = shift;
return undef if ! -d $dir;
my @disc;
my $wanted = sub {
my @stat = stat($_);
my $type = -d _ ? 'directory' : 'file';
push @disc, [ $type, $File::Find::name, l('not owned by root')]
if $stat[4] != 0;
push @disc, [ $type, $File::Find::name, l('world writable') ]
if (07777 & $stat[2] & 02);
push @disc, [ $type, $File::Find::name, l('group writable') ]
if (07777 & $stat[2] & 020);
};
File::Find::find($wanted, $dir);
return 1 if ! @disc;
my $out = "";
for (@disc) {
$_->[1] =~ s!^$dir/!!;
$out .= errmsg(" %s %s is %s\n", @$_);
}
return $out;
}
sub compile_link {
my $cref = shift || \%Conf;
for( qw/linkmode cgiurl vendroot cgidir cgiurl/) {
die errmsg("improper reference passed, missing: %s", $_)
if ! $cref->{$_};
}
return 1 if $cref->{linkmode} =~ /^\s*n/i;
my @args;
my $cginame = $cref->{cgiurl};
$cginame =~ s:.*/::;
$cref->{cgifile} = $cginame = "$cref->{relocate}$cref->{cgidir}/$cginame";
die errmsg("%s %s: %s", 'target file', $cref->{cgifile}, 'is a directory')
if -e $cref->{cgifile};
my $exec = "$cref->{relocate}$cref->{vendroot}/bin/compile_link";
die errmsg("%s %s: %s", 'executable file', $exec, 'not executable')
if ! -x $exec;
push @args, (
$cref->{linkmode} =~ /^\s*u/i
? '--unixmode'
: '--inetmode'
);
push @args, "--source=$cref->{relocate}$cref->{vendroot}/src";
push @args, "--outputfile=$cref->{relocate}$cref->{cgifile}";
push @args, "--port=$cref->{linkport}"
if $cref->{linkport};
push @args, "--host=$cref->{linkhost}"
if $cref->{linkhost};
push @args, "--nosuid"
if $cref->{cgiwrap};
push @args, "--nosuid"
if $cref->{cgiwrap};
for (@args) {
die errmsg("Improper argument: %s", $_)
if /"/;
$_ = qq{"$_"};
}
my $dir = $ENV{TMP} || '/tmp';
my $bdir = "$dir/compile_link.$$";
my $outfile = "$bdir/build.out";
my $errfile = "$bdir/build.err";
File::Path::mkpath($bdir);
push @args, "--build=$bdir";
system join " ",
$exec,
@args,
"2>$errfile",
">$outfile";
if($?) {
my $msg = `cat $errfile`;
die errmsg("Failed to compile and copy link:\n\n%s", $msg);
}
File::Path::rmtree($bdir);
unlink $errfile;
unlink $outfile;
return 1;
}
my @Action;
sub evaluate_action {
my $act = shift;
ref($act) eq 'HASH' or die "usage: evaluate_action(\%action)";
my $orig_dir;
my $error;
eval {
if($act->{chdir}) {
$orig_dir = cwd();
my $dir = $act->{chdir};
$dir = substitute($dir) if $dir =~ /__MVC_/;
chdir $dir
or die errmsg("Unable to change directory to %s.", $dir) . "\n";
}
if($act->{from_dir} and $act->{to_dir}) {
if($Conf{relocate}) {
$act->{to_dir} = "$Conf{relocate}$act->{to_dir}";
$act->{from_dir} = "$Conf{relocate}$act->{from_dir}";
}
copy_dir($act->{from_dir}, $act->{to_dir}, undef, $act);
if($act->{delete_from}) {
File::Path::rmtree($act->{from_dir});
}
}
if(my $sub = $act->{sub}) {
my $args = $act->{args} || [];
$sub->(@$args);
}
if(my $cmd = $act->{command}) {
$cmd = substitute($cmd) if $cmd =~ /__MVC_/;
system $cmd;
if($?) {
my $status = $? >> 8;
die errmsg(
"Command %s returned status %s: %s",
$cmd,
$status,
$!,
) . "\n";
}
}
};
$error = $@ if $@;
chdir $orig_dir if $orig_dir;
die $error if $error;
return;
}
sub build_cat {
my ($scale, $die, $warn, $opt) = @_;
debug("build_cat called scalesub=$scale");
$opt ||= {};
(
$scale && ! ref $scale eq 'CODE'
or
$die && ! ref $die eq 'CODE'
or
$warn && ! ref $warn eq 'CODE'
or
$opt && ! ref $opt eq 'HASH'
) and die errmsg("usage: %s", 'build_cat(\&scale,\&die,\&warn,$hashref)');
$die = sub { die errmsg(@_) . "\n"; } if ! $die;
$warn = sub { die errmsg(@_) . "\n"; } if ! $die;
my $cref = $opt->{configuration} || \%Conf;
my @action;
# Here we create an array of hashes. The elements:
# structure is:
#
# from_dir => directory to copy from (done before sub)
# to_dir => directory to copy to
# delete_from => delete from_dir when finished
# sub => subroutine to run
# args => subroutine args
# message => message for scale routine
# scale => value to be added to scale when done
# error => Error message if fails
# error_ok => Ignore error if it occurs
# error_warn => Issue conditional warning if error
# (dies if in batch mode)
#
# If "action_ref" option key is provided, it is used instead. (Unlikely
# ever to be used, obviously.)
CREATEACTION: {
if($opt->{action_ref}) {
@action = @{$opt->{action_ref}};
last CREATEACTION;
}
push @action, {
sub => \&substitute_cryptpw,
message => errmsg('Encrypting passwords'),
scale => 1,
};
push @action, {
sub => \&compile_link,
args => [ $cref ],
message => errmsg('Compiling link programs'),
scale => 4,
};
push @action, {
sub => sub {
hammer_symlinks("$Conf{relocate}$Conf{catroot}"),
},
message => errmsg("Cleaning up catalog directory"),
scale => 1,
} if -d "$Conf{relocate}$Conf{catroot}";
if(my $wref = $Window{precopy_commands}) {
$wref->{contents} ||= [];
for(@{$wref->{contents}}) {
my $cref = $Content{$_};
$cref->{scale} = 1 unless defined $cref->{scale};
$cref->{message} = "Running $cref->{command}"
unless $cref->{message};
$cref->{error_warn} = 1
unless $cref->{error_ok};
if(! $cref->{conditional} or $cref->{conditional}->()) {
push @action, $cref;
}
}
}
push @action, {
from_dir => "$Conf{vendroot}/$Conf{demotype}",
to_dir => $Conf{catroot},
dmode => 02770,
fmode => 0660,
Substitute => \%Conf,
error => $Build_error{demotype},
message => errmsg("Copying base demo skeleton"),
scale => 3,
};
push @action, {
delete_from => 1,
dmode => 0775,
error => $Build_error{demotype},
fmode => 0664,
from_dir => "$Conf{catroot}/html",
message => errmsg("Copying public HTML files"),
scale => 1,
to_dir => $Conf{samplehtml},
};
push @action, {
delete_from => 1,
dmode => 0775,
error => $Build_error{demotype},
fmode => 0664,
from_dir => "$Conf{catroot}/images",
message => errmsg("Copying image files"),
scale => 2,
symlink_to => 1,
to_dir => $Conf{imagedir},
};
if(my $wref = $Window{postcopy_commands}) {
$wref->{contents} ||= [];
for(@{$wref->{contents}}) {
my $cref = $Content{$_};
$cref->{scale} = 1 unless defined $cref->{scale};
$cref->{chdir} = $Conf{catroot} unless $cref->{chdir};
$cref->{message} = "Running $cref->{command}"
unless $cref->{message};
$cref->{error_warn} = 1
unless $cref->{error_ok};
if(! $cref->{conditional} or $cref->{conditional}->()) {
push @action, $cref;
}
}
}
push @action, {
sub => \&add_catalog,
message => errmsg("Adding catalog to interchange.cfg"),
scale => 1,
} if $cref->{add_catalog};
debug("run_catalog=$cref->{run_catalog} server_running=" . server_running());
push @action, {
sub => \&run_catalog,
message => errmsg("Running catalog"),
scale => 1,
} if $cref->{run_catalog} and server_running();
}
my $total_scale = 0;
foreach my $act (@action) {
$total_scale += $act->{scale};
}
debug("total scale amount=$total_scale scalesub=$scale");
## install_scale returns a closure implementing whatever scale
## there is....
my $msg = errmsg("Installing catalog: %s", $Conf{catalogname});
my $scale_call;
debug("scale_call=$scale_call");
if(! $opt->{event_driven}) {
$scale_call = $scale->($total_scale, $msg)
if $scale;
foreach my $act (@action) {
debug("action: " . uneval($act));
$scale_call->('start', $act->{scale}, errmsg($act->{message}))
if $scale_call;
#select(undef,undef,undef, .75);
my $orig_dir;
eval {
evaluate_action($act);
};
if(! $@) {
$scale_call->('end')
if $scale_call;
}
elsif($act->{error_ok}) {
debug("action error_ok: $@");
my $msg = errmsg($act->{message}) . "..." . errmsg('failed') . ".";
$scale_call->('end', undef, $msg)
if $scale_call;;
}
elsif($act->{error_warn}) {
debug("action error_warn: $@");
my $msg = $@;
$warn->($msg)
or do {
$die->($msg);
return undef;
};
}
else {
debug("action fatal_error: $@");
$die->( errmsg("Error installing catalog %s: %s"));
return undef;
}
chdir $orig_dir if $orig_dir;
}
$scale_call->('finish')
if $scale_call;
}
elsif($scale) {
eval {
$scale->($total_scale, $msg, \&evaluate_action, @action);
};
if($@) {
debug("action fatal_error: $@");
$die->( errmsg("Error installing catalog %s: %s"));
return undef;
}
}
else {
die "Must have scale subroutine call if event-driven\n";
}
}
package readline;
use vars qw/$AcceptLine/;
sub discard_ReadKey {
return unless $Term::ReadKey::VERSION;
my $timeout = shift || '-1';
local($^W);
eval {
Term::ReadKey::ReadKey(-1, $readline::term_IN);
};
}
sub F_CatchHelp {
$AcceptLine = "\cY";
}
sub F_CatchCancel {
$AcceptLine = "\cX";
discard_ReadKey(1);
}
sub F_CatchBackward {
$AcceptLine = "\cB";
discard_ReadKey(1);
}
sub F_CatchForward {
$AcceptLine = "\cF";
discard_ReadKey(1);
}
1;
__END__
Jump to Line
Something went wrong with that request. Please try again.