bdbada28a8
Also warns about some bad characters in record names, but only the ones that are known to cause known bad behaviour.
434 lines
14 KiB
Perl
Executable File
434 lines
14 KiB
Perl
Executable File
eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*-
|
|
if $running_under_some_shell; # makeBaseApp
|
|
|
|
# Authors: Ralph Lange, Marty Kraimer, Andrew Johnson and Janet Anderson
|
|
# $Revision-Id$
|
|
|
|
use FindBin qw($Bin);
|
|
use lib ("$Bin/../../lib/perl", $Bin);
|
|
|
|
use Cwd;
|
|
use Getopt::Std;
|
|
use File::Find;
|
|
use File::Path 'mkpath';
|
|
use EPICS::Path;
|
|
use EPICS::Release;
|
|
|
|
$app_top = cwd();
|
|
|
|
%release = (TOP => $app_top);
|
|
@apps = (TOP);
|
|
|
|
$bad_ident_chars = '[^0-9A-Za-z_]';
|
|
|
|
&readReleaseFiles("configure/RELEASE", \%release, \@apps);
|
|
&expandRelease(\%release);
|
|
&get_commandline_opts; # Check command-line options
|
|
&GetUser; # Ensure we know who's in charge
|
|
|
|
#
|
|
# Declare two default callback routines for file copy plus two
|
|
# hook routines to add conversions
|
|
# These may be overriden within $top/$apptypename/Replace.pl
|
|
|
|
# First: the hooks
|
|
sub ReplaceFilenameHook { return $_[0]; }
|
|
sub ReplaceLineHook { return $_[0]; }
|
|
|
|
# ReplaceFilename
|
|
# called with the source (template) file or directory name, returns
|
|
# the target file/dir name (current directory is the application top).
|
|
|
|
# Inside iocBoot, templates can install different files for different
|
|
# IOC architectures or OSs: 'name@<arch>', 'name@<os>' & 'name@Common'
|
|
# The best match is installed as 'name', but if the best matching file
|
|
# is empty then no file is created, allowing a file 'name@Common' to
|
|
# be omitted by providing an empty 'name@<arch>' or 'name@<os>'.
|
|
|
|
# Returning an empty string means don't copy this file.
|
|
sub ReplaceFilename { # (filename)
|
|
my($file) = $_[0];
|
|
$file =~ s|.*/CVS/?.*||; # Ignore CVS files and Replace.pl scripts
|
|
$file =~ s|.*/$apptypename/Replace\.pl$||;
|
|
|
|
if($opt_i) {
|
|
# Handle name@arch stuff, copy only the closest matching file
|
|
# NB: Won't work with directories, don't use '@' in a directory name!
|
|
my($base,$filearch) = split /@/, $file;
|
|
if ($base ne $file) { # This file is arch-specific
|
|
my($os,$cpu,$toolset) = split /-/, $arch, 3;
|
|
if (-r "$base\@$arch") { # A version exists for this arch
|
|
$base = '' unless ($filearch eq $arch && -s $file);
|
|
} elsif (-r "$base\@$os") { # A version exists for this os
|
|
$base = '' unless ($filearch eq $os && -s $file);
|
|
} elsif ( $ENV{EPICS_HOST_ARCH} !~ "$os-$cpu" &&
|
|
-r "$base\@Cross" ) { # Cross version exists
|
|
$base = '' unless ($filearch eq "Cross" && -s $file);
|
|
} elsif (-r "$base\@Common") { # Default version exists
|
|
$base = '' unless ($filearch eq "Common" && -s $file);
|
|
} else { # No default version
|
|
$base = '';
|
|
}
|
|
$file = $base; # Strip the @... part from the target name
|
|
}
|
|
$file =~ s|/$apptypename|/iocBoot|; # templateBoot => iocBoot
|
|
}
|
|
if ($ioc) {
|
|
$file =~ s|/iocBoot/ioc|/iocBoot/$ioc|; # name the ioc subdirectory
|
|
$file =~ s|_IOC_|$ioc|;
|
|
} else {
|
|
$file =~ s|.*/iocBoot/ioc/?.*||; # Not doing IOCs here
|
|
}
|
|
if ($app) {
|
|
$file =~ s|/$apptypename|/$appdir|; # templateApp => namedApp
|
|
$file =~ s|/$appdir/configure|/configure/$apptype|;
|
|
}
|
|
$file =~ s|_APPNAME_|$appname|;
|
|
$file =~ s|_APPTYPE_|$apptype|;
|
|
my $qmtop = quotemeta($top);
|
|
$file =~ s|$qmtop/||; # Change to the target location
|
|
$file = &ReplaceFilenameHook($file); # Call the apptype's hook
|
|
return $file;
|
|
}
|
|
|
|
# ReplaceLine
|
|
# called with one line of a file, returns the line after replacing
|
|
# this and that
|
|
sub ReplaceLine { # (line)
|
|
my($line) = $_[0];
|
|
$line =~ s/_IOC_/$ioc/g if ($ioc);
|
|
$line =~ s/_USER_/$user/go;
|
|
$line =~ s/_EPICS_BASE_/$app_epics_base/go;
|
|
$line =~ s/_TEMPLATE_TOP_/$app_template_top/go;
|
|
$line =~ s/_TOP_/$app_top/go;
|
|
$line =~ s/_APPNAME_/$appname/g;
|
|
$line =~ s/_CSAFEAPPNAME_/$csafeappname/g;
|
|
$line =~ s/_APPTYPE_/$apptype/go;
|
|
$line =~ s/_ARCH_/$arch/go if ($opt_i);
|
|
$line = &ReplaceLineHook($line); # Call the apptype's hook
|
|
return $line;
|
|
}
|
|
|
|
# Source replace overrides for file copy
|
|
if (-r "$top/$apptypename/Replace.pl") {
|
|
require "$top/$apptypename/Replace.pl";
|
|
}
|
|
|
|
#
|
|
# Copy files and dirs from <top> (other than App & Boot) if not present
|
|
#
|
|
opendir TOPDIR, "$top" or die "Can't open $top: $!";
|
|
foreach $f ( grep !/^\.\.?$|^[^\/]*(App|Boot)/, readdir TOPDIR ) {
|
|
find({wanted => \&FCopyTree, follow => 1}, "$top/$f") unless (-e "$f");
|
|
}
|
|
closedir TOPDIR;
|
|
|
|
#
|
|
# Create ioc directories
|
|
#
|
|
if ($opt_i) {
|
|
find({wanted => \&FCopyTree, follow => 1}, "$top/$apptypename");
|
|
|
|
$appname=$appnameIn if $appnameIn;
|
|
foreach $ioc ( @names ) {
|
|
($appname = $ioc) =~ s/App$// if !$appnameIn;
|
|
($csafeappname = $appname) =~ s/$bad_ident_chars/_/og;
|
|
$ioc = "ioc" . $ioc unless ($ioc =~ m/ioc/);
|
|
if (-d "iocBoot/$ioc") {
|
|
print "iocBoot/$ioc exists, not modified.\n";
|
|
next;
|
|
}
|
|
find({wanted => \&FCopyTree, follow => 1}, "$top/$apptypename/ioc");
|
|
}
|
|
exit 0; # finished here for -i (no xxxApps)
|
|
}
|
|
|
|
#
|
|
# Create app directories (if any names given)
|
|
#
|
|
foreach $app ( @names ) {
|
|
($appname = $app) =~ s/App$//;
|
|
($csafeappname = $appname) =~ s/$bad_ident_chars/_/og;
|
|
$appdir = $appname . "App";
|
|
if (-d "$appdir") {
|
|
print "$appname exists, not modified.\n";
|
|
next;
|
|
}
|
|
print "Creating $appname from template type $apptypename\n" if $opt_d;
|
|
find({wanted => \&FCopyTree, follow => 1}, "$top/$apptypename/");
|
|
}
|
|
|
|
exit 0; # END OF SCRIPT
|
|
|
|
#
|
|
# Get commandline options and check for validity
|
|
#
|
|
sub get_commandline_opts { #no args
|
|
getopts("a:b:dhilp:T:t:u:") or Cleanup(1);
|
|
|
|
# Options help
|
|
Cleanup(0) if $opt_h;
|
|
|
|
# Locate epics_base
|
|
my ($command) = UnixPath($0);
|
|
if ($opt_b) { # first choice is -b base
|
|
$epics_base = UnixPath($opt_b);
|
|
} elsif ($release{"EPICS_BASE"}) { # second choice is configure/RELEASE
|
|
$epics_base = UnixPath($release{"EPICS_BASE"});
|
|
$epics_base =~s|^\$\(TOP\)/||;
|
|
} elsif ($ENV{EPICS_MBA_BASE}) { # third choice is env var EPICS_MBA_BASE
|
|
$epics_base = UnixPath($ENV{EPICS_MBA_BASE});
|
|
} elsif ($command =~ m|/bin/|) { # assume script was run with full path to base
|
|
$epics_base = $command;
|
|
$epics_base =~ s|^(.*)/bin/.*makeBaseApp.*|$1|;
|
|
}
|
|
$epics_base and -d "$epics_base" or Cleanup(1, "Can't find EPICS base");
|
|
$app_epics_base = LocalPath($epics_base);
|
|
$app_epics_base =~ s|^\.\.|\$(TOP)/..|;
|
|
|
|
# Locate template top directory
|
|
if ($opt_T) { # first choice is -T templ-top
|
|
$top = UnixPath($opt_T);
|
|
} elsif ($release{"TEMPLATE_TOP"}) { # second choice is configure/RELEASE
|
|
$top = UnixPath($release{"TEMPLATE_TOP"});
|
|
$top =~s|^\$\(EPICS_BASE\)|$epics_base|;
|
|
$top =~s|^\$\(TOP\)/||;
|
|
}
|
|
$top = $ENV{EPICS_MBA_TEMPLATE_TOP} unless $top && -d $top; # third choice is env var
|
|
$top = $epics_base . "/templates/makeBaseApp/top" unless $top && -d $top; # final
|
|
$top and -d "$top" or Cleanup(1, "Can't find template top directory");
|
|
$app_template_top = LocalPath($top);
|
|
$app_template_top =~s|^\.\.|\$(TOP)/..|;
|
|
$app_template_top =~s|^$epics_base/|\$\(EPICS_BASE\)/|;
|
|
|
|
# Print application type list?
|
|
if ($opt_l) {
|
|
&ListAppTypes;
|
|
exit 0; # finished for -l command
|
|
}
|
|
|
|
if (!@ARGV){
|
|
if ($opt_t) {
|
|
if ($opt_i) {
|
|
my @iocs = map {s/iocBoot\///; $_} glob 'iocBoot/ioc*';
|
|
if (@iocs) {
|
|
print "The following IOCs already exist here:\n",
|
|
map {" $_\n"} @iocs;
|
|
}
|
|
print "Name the IOC(s) to be created.\n",
|
|
"Names given will have \"ioc\" prepended to them.\n",
|
|
"IOC names? ";
|
|
} else {
|
|
print "Name the application(s) to be created.\n",
|
|
"Names given will have \"App\" appended to them.\n",
|
|
"Application names? ";
|
|
}
|
|
$namelist = <STDIN>;
|
|
chomp($namelist);
|
|
@names = split /[\s,]/, $namelist;
|
|
} else {
|
|
Cleanup(1);
|
|
}
|
|
} else {
|
|
@names = @ARGV;
|
|
}
|
|
|
|
# ioc architecture and application name
|
|
if ($opt_i && @names) {
|
|
|
|
# ioc architecture
|
|
opendir BINDIR, "$epics_base/bin" or die "Can't open $epics_base/bin: $!";
|
|
my @archs = grep !/^\./, readdir BINDIR; # exclude .files
|
|
closedir BINDIR;
|
|
if ($opt_a) {
|
|
$arch = $opt_a;
|
|
} elsif (@archs == 1) {
|
|
$arch = $archs[0];
|
|
print "Using target architecture $arch (only one available)\n";
|
|
} else {
|
|
print "The following target architectures are available in base:\n";
|
|
foreach $arch (@archs) {
|
|
print " $arch\n";
|
|
}
|
|
print "What architecture do you want to use? ";
|
|
$arch = <STDIN>;
|
|
chomp($arch);
|
|
}
|
|
grep /^$arch$/, @archs or Cleanup(1, "Target architecture $arch not available");
|
|
|
|
# Application name
|
|
if ($opt_p){
|
|
$appnameIn = $opt_p if ($opt_p);
|
|
} else {
|
|
my @apps = glob '*App';
|
|
if (@apps) {
|
|
print "The following applications are available:\n",
|
|
map {s/App$//; " $_\n"} @apps;
|
|
}
|
|
print "What application should the IOC(s) boot?\n",
|
|
"The default uses the IOC's name, even if not listed above.\n",
|
|
"Application name? ";
|
|
$appnameIn = <STDIN>;
|
|
chomp($appnameIn);
|
|
}
|
|
}
|
|
|
|
# Application type
|
|
$appext = $opt_i ? "Boot" : "App";
|
|
if ($opt_t) { # first choice is -t type
|
|
$apptype = $opt_t;
|
|
$apptype =~ s/$appext$//;
|
|
} elsif ($ENV{EPICS_MBA_DEF_APP_TYPE}) { # second choice is environment var
|
|
$apptype = $ENV{EPICS_MBA_DEF_APP_TYPE};
|
|
$apptype =~ s/(App)|(Boot)$//;
|
|
} elsif (-d "$top/default$appext") { # third choice is default
|
|
$apptype = "default";
|
|
} elsif (-d "$top/example$appext") { # fourth choice is example
|
|
$apptype = "example";
|
|
}
|
|
$apptype or Cleanup(1, "No application type set");
|
|
$apptypename = $apptype . $appext;
|
|
(-r "$top/$apptypename") or
|
|
Cleanup(1, "Can't access template directory '$top/$apptypename'.\n");
|
|
|
|
print "\nCommand line / environment options validated:\n"
|
|
. " Templ-Top: $top\n"
|
|
. "Templ-Type: $apptype\n"
|
|
. "Templ-Name: $apptypename\n"
|
|
. " opt_i: $opt_i\n"
|
|
. " arch: $arch\n"
|
|
. "EPICS-Base: $epics_base\n\n" if $opt_d;
|
|
}
|
|
|
|
#
|
|
# List application types
|
|
#
|
|
sub ListAppTypes { # no args
|
|
opendir TYPES, "$top" or die "Can't open $top: $!";
|
|
my @allfiles = readdir TYPES;
|
|
closedir TYPES;
|
|
my @apps = grep /.*App$/, @allfiles;
|
|
my @boots = grep /.*Boot$/, @allfiles;
|
|
print "Valid application types are:\n";
|
|
foreach $name (@apps) {
|
|
$name =~ s|App||;
|
|
printf "\t$name\n" if ($name && -r "$top/$name" . "App");
|
|
}
|
|
print "Valid iocBoot types are:\n";
|
|
foreach $name (@boots) {
|
|
$name =~ s|Boot||;
|
|
printf "\t$name\n" if ($name && -r "$top/$name" . "Boot");;
|
|
}
|
|
}
|
|
|
|
#
|
|
# Copy a file with replacements
|
|
#
|
|
sub CopyFile { # (source)
|
|
$source = $_[0];
|
|
$target = &ReplaceFilename($source);
|
|
|
|
if ($target and !-e $target) {
|
|
open(INP, "<$source") and open(OUT, ">$target")
|
|
or die "$! Copying $source -> $target";
|
|
|
|
print "Copying file $source -> $target\n" if $opt_d;
|
|
while (<INP>) {
|
|
print OUT &ReplaceLine($_);
|
|
}
|
|
close INP; close OUT;
|
|
}
|
|
}
|
|
|
|
#
|
|
# Find() callback for file or structure copy
|
|
#
|
|
sub FCopyTree {
|
|
chdir $app_top; # Sigh
|
|
if (-d "$File::Find::name"
|
|
and ($dir = &ReplaceFilename($File::Find::name))) {
|
|
print "Creating directory $dir\n" if $opt_d;
|
|
&mkpath($dir) unless (-d "$dir");
|
|
} else {
|
|
&CopyFile($File::Find::name);
|
|
}
|
|
chdir $File::Find::dir;
|
|
}
|
|
|
|
#
|
|
# Cleanup and exit
|
|
#
|
|
sub Cleanup { # (return-code [ messsage-line1, line 2, ... ])
|
|
my ($rtncode, @message) = @_;
|
|
|
|
if (@message) {
|
|
print join("\n", @message), "\n";
|
|
} else {
|
|
&Usage;
|
|
}
|
|
exit $rtncode;
|
|
}
|
|
|
|
sub Usage {
|
|
print <<EOF;
|
|
Usage:
|
|
<base>/bin/<arch>/makeBaseApp.pl -h
|
|
display help on command options
|
|
<base>/bin/<arch>/makeBaseApp.pl -l [options]
|
|
list application types
|
|
<base>/bin/<arch>/makeBaseApp.pl -t type [options] [app ...]
|
|
create application directories
|
|
<base>/bin/<arch>/makeBaseApp.pl -i -t type [options] [ioc ...]
|
|
create ioc boot directories
|
|
where
|
|
app Application name (the created directory will have \"App\" appended)
|
|
ioc IOC name (the created directory will have \"ioc\" prepended)
|
|
EOF
|
|
print <<EOF if ($opt_h);
|
|
|
|
-a arch Set the IOC architecture for use with -i (e.g. vxWorks-68040)
|
|
If arch is not specified, you will be prompted
|
|
-b base Set the location of EPICS base (full path)
|
|
If not specified, base path is taken from configure/RELEASE
|
|
If configure does not exist, from environment
|
|
If not found in environment, from makeBaseApp.pl location
|
|
-d Enable debug messages
|
|
-i Specifies that ioc boot directories will be generated
|
|
-l List valid application types for this installation
|
|
If this is specified the other options are not used
|
|
-p app Set the application name for use with -i
|
|
If not specified, you will be prompted
|
|
-T top Set the template top directory (where the application templates are)
|
|
If not specified, top path is taken from configure/RELEASE
|
|
If configure does not exist, top path is taken from environment
|
|
If not found in environment, the templates from EPICS base are used
|
|
-t type Set the application type (-l for a list of valid types)
|
|
If not specified, type is taken from environment
|
|
If not found in environment, \"default\" is used
|
|
-u user Set username; overrides OS defaults
|
|
|
|
Environment:
|
|
EPICS_MBA_DEF_APP_TYPE Application type you want to use as default
|
|
EPICS_MBA_TEMPLATE_TOP Template top directory
|
|
EPICS_MBA_BASE Location of EPICS base
|
|
|
|
Example: Create exampleApp
|
|
|
|
<base>/bin/<arch>/makeBaseApp.pl -t example example
|
|
<base>/bin/<arch>/makeBaseApp.pl -i -t example example
|
|
EOF
|
|
}
|
|
|
|
sub GetUser {
|
|
$user = $opt_u || $ENV{USER} || $ENV{USERNAME} || Win32::LoginName();
|
|
|
|
unless ($user) {
|
|
print "Strange, I cannot figure out your user name!\n";
|
|
print "What should you be called ? ";
|
|
$user = <STDIN>;
|
|
chomp $user;
|
|
}
|
|
$user =~ tr/-a-zA-Z0-9_:;[]<>//cd; # Sanitize; these are the legal chars
|
|
die "No user name" unless $user;
|
|
}
|