Index: NEMO/trunk/ext/FCM/COPYRIGHT.txt
===================================================================
--- NEMO/trunk/ext/FCM/COPYRIGHT.txt (revision 9596)
+++ NEMO/trunk/ext/FCM/COPYRIGHT.txt (revision 9596)
@@ -0,0 +1,109 @@
+!------------------------------------------------------------------------------!
+! Flexible Configuration Management Software License !
+! !
+! Please read this Software Licence as you will be bound by its terms !
+! if you use the Software !
+!------------------------------------------------------------------------------!
+
+The Licensor:
+-------------
+
+The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom
+--------------------------------------------------------------------------------
+
+1. Licence.
+-----------
+
+The Met Office grants you a non-exclusive, royalty free; world-wide,
+transferable Licence to use, modify, copy and distribute the Flexible
+Configuration Management software ("the software") accompanying this License
+providing:
+
+a. you undertake to provide to the Met Office a copy of any modifications made
+ by you on the same terms contained within this licence agreement;
+
+b. modified files carry prominent notices stating that you changed the files
+ and the date of change;
+
+c. distribution of original or modified files is made free of charge under the
+ terms of this Licence;
+
+d. the appropriate copyright notices, the above copyright notice and a
+ disclaimer of warranty is included with the distribution.
+
+2. Ownership.
+-------------
+
+The Flexible Configuration Management software is Crown copyright and is
+reproduced with the permission of Met Office under delegated authority from
+the Controller of HMSO. The software and documentation are provided to you to
+allow you to exercise your rights under this License, which is granted to you.
+
+3. Duration.
+------------
+
+This license will remain in effect until terminated.
+
+4. Termination.
+---------------
+
+You may terminate this license at any time by removing all copies of the
+software from your system. This License will terminate immediately without
+notice from us if you fail to comply with any of the provisions of this
+License or in the event of your breaching the terms of this licence you are
+given notice that the license has been terminated. Upon termination you will
+delete all copies of the software and any related documentation.
+
+5. Disclaimer of Warranty.
+--------------------------
+
+a. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES,
+ INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY
+ AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY
+ REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND
+ PLATFORMS.
+
+b. In no event does the Met Office warrant that the software or related
+ documentation will satisfy your requirements, that the software and
+ documentation will be without errors or defects or that the operation of
+ the software will be uninterrupted.
+
+c. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, INCLUDING
+ BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE SOFTWARE
+ OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF THE MET
+ OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+6. General Provisions.
+----------------------
+
+a. You will not do anything, relating to this software that will bring the Met
+ Office into disrepute.
+
+b. You will not use the name of the Met Office or any other contributor to
+ endorse or promote any products derived from the software without the
+ written permission of the Met Office.
+
+7. Acknowledgements.
+--------------------
+
+The logic to extract the calling interfaces of top level subroutines and
+functions from a Fortran source file is adapted from a script developed at
+ECMWF and is provided by kind permission of ECMWF under the same terms of this
+Licence.
+
+8. Entire Agreement.
+--------------------
+
+This License constitutes the entire agreement between us with respect to your
+rights or warranties for using the software and related documentation. If any
+provision of this agreement is determined to be invalid or unenforceable the
+remaining provisions shall continue in full force.
+
+9. Governing Law.
+-----------------
+
+This Agreement is governed by and construed in accordance with the Laws of
+England.
+
+--------------------------------------------------------------------------------
+ © British Crown copyright 2006-10.
Index: NEMO/trunk/ext/FCM/LICENSE.html
===================================================================
--- NEMO/trunk/ext/FCM/LICENSE.html (revision 9596)
+++ NEMO/trunk/ext/FCM/LICENSE.html (revision 9596)
@@ -0,0 +1,154 @@
+
+
+
+
+ Flexible Configuration Management Software License
+
+
+
+
+
+
+ Flexible Configuration Management Software License
+
+ Please read this Software Licence as you will be bound by its terms if
+ you use the Software
+
+ The Licensor:
+
+ The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom
+
+ 1. Licence.
+
+ The Met Office grants you a non-exclusive, royalty free; world-wide,
+ transferable Licence to use, modify, copy and distribute the Flexible
+ Configuration Management software ("the software") accompanying this License
+ providing:
+
+
+ - you undertake to provide to the Met Office a copy of any modifications
+ made by you on the same terms contained within this licence agreement;
+
+ - modified files carry prominent notices stating that you changed the
+ files and the date of change;
+
+ - distribution of original or modified files is made free of charge under
+ the terms of this Licence;
+
+ - the appropriate copyright notices, the above copyright notice and a
+ disclaimer of warranty is included with the distribution.
+
+
+ 2. Ownership.
+
+ The Flexible Configuration Management software is Crown copyright and is
+ reproduced with the permission of Met Office under delegated authority from
+ the Controller of HMSO. The software and documentation are provided to you to
+ allow you to exercise your rights under this License, which is granted to
+ you.
+
+ 3. Duration.
+
+ This license will remain in effect until terminated.
+
+ 4. Termination.
+
+ You may terminate this license at any time by removing all copies of the
+ software from your system. This License will terminate immediately without
+ notice from us if you fail to comply with any of the provisions of this
+ License or in the event of your breaching the terms of this licence you are
+ given notice that the license has been terminated. Upon termination you will
+ delete all copies of the software and any related documentation.
+
+ 5. Disclaimer of Warranty.
+
+
+ - THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES,
+ INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY
+ AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY
+ REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND
+ PLATFORMS.
+
+ - In no event does the Met Office warrant that the software or related
+ documentation will satisfy your requirements, that the software and
+ documentation will be without errors or defects or that the operation of
+ the software will be uninterrupted.
+
+ - IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES,
+ INCLUDING BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE
+ SOFTWARE OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF
+ THE MET OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH
+ DAMAGES.
+
+
+ 6. General Provisions.
+
+
+ - You will not do anything, relating to this software that will bring the
+ Met Office into disrepute.
+
+ - You will not use the name of the Met Office or any other contributor to
+ endorse or promote any products derived from the software without the
+ written permission of the Met Office.
+
+
+ 7. Acknowledgements.
+
+ The logic to extract the calling interfaces of top level subroutines and
+ functions from a Fortran source file is adapted from a script developed at
+ ECMWF and is provided by kind permission of ECMWF under the same terms of this
+ Licence.
+
+ 8. Entire Agreement.
+
+ This License constitutes the entire agreement between us with respect to
+ your rights or warranties for using the software and related documentation.
+ If any provision of this agreement is determined to be invalid or
+ unenforceable the remaining provisions shall continue in full force.
+
+ 9. Governing Law.
+
+ This Agreement is governed by and construed in accordance with the Laws of
+ England.
+
+
+ © British Crown copyright 2006-10.
+
+
+
Index: NEMO/trunk/ext/FCM/README
===================================================================
--- NEMO/trunk/ext/FCM/README (revision 9596)
+++ NEMO/trunk/ext/FCM/README (revision 9596)
@@ -0,0 +1,4 @@
+FCM release 1-5 created from revision 3579.
+
+For further details please refer to the release notes
+which can be found in the directory doc/release_notes.
Index: NEMO/trunk/ext/FCM/bin/fcm
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm (revision 9596)
@@ -0,0 +1,66 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use Fcm::CLI;
+use Fcm::Interactive;
+
+if (!caller()) {
+ main(@ARGV);
+}
+
+sub main {
+ local(@ARGV) = @_;
+ if (@ARGV && $ARGV[0] eq 'gui-internal') {
+ shift(@ARGV);
+ Fcm::Interactive::set_impl(
+ 'Fcm::Interactive::InputGetter::GUI',
+ {geometry => shift(@ARGV)},
+ );
+ }
+ Fcm::CLI::invoke();
+}
+
+__END__
+
+=head1 NAME
+
+fcm
+
+=head1 SYNOPSIS
+
+fcm SUBCOMMAND [OPTIONS] [ARGUMENTS]
+
+=head1 OVERVIEW
+
+B is the command line client for code management commands, the extract
+system and the build system of the Flexible Configuration Management (FCM)
+system. For full detail of the system, please refer to the FCM user guide,
+which you should receive with this distribution in both HTML and PDF formats.
+
+Run "fcm help" to access the built-in tool documentation.
+
+=head1 AUTHOR
+
+FCM Team L.
+Please feedback any bug reports or feature requests to us by e-mail.
+
+=head1 SEE ALSO
+
+L,
+L,
+L
+
+=head1 COPYRIGHT
+
+You can use this release of B freely under the terms of the FCM LICENSE,
+which you should receive with this distribution.
+
+=cut
Index: NEMO/trunk/ext/FCM/bin/fcm_graphic_diff
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_graphic_diff (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_graphic_diff (revision 9596)
@@ -0,0 +1,96 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use Getopt::Long qw{GetOptions};
+
+# ------------------------------------------------------------------------------
+
+my ($u, @label);
+GetOptions ('u' => \$u, 'L=s' => \@label);
+
+# Check existence of files
+for my $i (0 .. 1) {
+ die $ARGV[$i], ': not found, abort' unless $ARGV[$i] and -f $ARGV[$i];
+}
+
+my ($old, $new) = @ARGV;
+
+if ($old =~ m#.svn/empty-file$#) {
+ print 'Skipping new file', "\n\n";
+
+} elsif ($new =~ m#.svn/empty-file$#) {
+ print 'Skipping deleted file', "\n\n";
+
+} elsif (-z $old) {
+ print 'Skipping as old file is empty (or does not exist)', "\n\n";
+
+} elsif (-z $new) {
+ print 'Skipping as new file is empty (or deleted)', "\n\n";
+
+} elsif (-B $new) {
+ print 'Skipping binary file', "\n\n";
+
+} else {
+ # Print descriptions of files
+ if (@label >= 2) {
+ print '--- ', $label[0], "\n", '+++ ', $label[1], "\n\n";
+ }
+
+ # FCM_GRAPHIC_DIFF is the graphical diff tool command
+ my $cmd = (exists $ENV{FCM_GRAPHIC_DIFF} ? $ENV{FCM_GRAPHIC_DIFF} : 'xxdiff');
+
+ if ($cmd) {
+ my @options = ();
+
+ # Set options for labels if appropriate
+ if (@label >= 2) {
+ if ($cmd eq 'tkdiff') {
+ # Use tkdiff
+ @options = ('-L', $label[0], '-L', $label[1]);
+
+ } elsif ($cmd eq 'xxdiff') {
+ # Use xxdiff
+ @options = ('--title1', $label[0], '--title2', $label[1]);
+ }
+ }
+
+ # Execute the command
+ my @command = ($cmd, @options, $old, $new);
+ exec (@command) or die 'Cannot execute: ', join (' ', @command);
+ }
+
+ exit;
+}
+
+__END__
+
+=head1 NAME
+
+fcm_graphic_diff
+
+=head1 SYNOPSIS
+
+ fcm_graphic_diff [-u] [-L OLD_DESC] [-L NEW_DESC] OLD NEW
+
+=head1 DESCRIPTION
+
+Wrapper script which invokes a graphical diff tool. Its interface is
+compatible with the "svn diff" command and can be used in combination with
+its "--diff-cmd" option. The command prints the OLD_DESC and NEW_DESC if
+they are both set. The two arguments OLD and NEW must be set and are the
+files to compare. The graphical diff tool invoked depends on the value of
+the FCM_GRAPHIC_DIFF environment variable. The command exits if the
+environment variable is not set.
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/bin/fcm_graphic_merge
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_graphic_merge (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_graphic_merge (revision 9596)
@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+my ($base, $mine, $older, $yours) = @ARGV;
+
+# FCM_GRAPHIC_MERGE is the graphical merge tool command
+my $cmd = (exists $ENV{FCM_GRAPHIC_MERGE} ? $ENV{FCM_GRAPHIC_MERGE} : 'xxdiff');
+
+my $rc = 2;
+my $out = '';
+if ($cmd eq 'xxdiff') {
+ # Launch xxdiff
+ my @command = ($cmd, qw/-m -M/, $base, qw/-O -X/, $mine, $older, $yours);
+ my ($cmd_out) = qx(@command);
+ my $cmd_rc = $?;
+
+ # Parse output from xxdiff
+ if ($cmd_out) {
+ chomp $cmd_out;
+ if ($cmd_out eq 'NODECISION') {
+ $out = 'made no decision';
+ $rc = 1;
+
+ } elsif ($cmd_out eq 'MERGED' and $cmd_rc) {
+ $out = 'not resolved all the conflicts';
+ $rc = 1;
+
+ } else {
+ $out = lc ($cmd_out);
+ $rc = 0;
+ }
+
+ } else {
+ print STDERR $cmd, ': failed, abort.', "\n";
+ }
+
+} else {
+ # Throw error for unknown/undefined graphic merge tool
+ print STDERR ($cmd ? $cmd . ': ' : ''),
+ 'unknown/undefined graphic merge tool, abort.', "\n";
+}
+
+if ($rc == 1) {
+ # Merge unresolved
+ print 'You have ', $out, '.', "\n";
+
+} elsif ($rc == 0) {
+ # Merge resolved
+ print 'You ', $out, ' all the changes.', "\n";
+}
+
+exit $rc;
+
+__END__
+
+=head1 NAME
+
+fcm_graphic_merge
+
+=head1 SYNOPSIS
+
+ fcm_graphic_merge BASE MINE OLDER YOURS
+
+=head1 DESCRIPTION
+
+Wrapper script which invokes a graphical merge tool. It returns 0 on
+success, 1 if conflicts not resolved or 2 on failure. (This is similar to
+GNU diff3.) BASE is the file you want to save the merge result into. MINE
+is the original file. YOURS is the file you want MINE to merge with. OLDER
+is the common ancestor of MINE and YOURS.
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/bin/fcm_gui
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_gui (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_gui (revision 9596)
@@ -0,0 +1,1346 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use Cwd;
+use Fcm::Config;
+use Fcm::Keyword;
+use Fcm::Timer;
+use Fcm::Util;
+use File::Basename;
+use File::Spec;
+use Tk;
+use Tk::ROText;
+
+# ------------------------------------------------------------------------------
+
+# Argument
+if (@ARGV) {
+ my $dir = shift @ARGV;
+ chdir $dir if -d $dir;
+}
+
+# Get configuration settings
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+# ------------------------------------------------------------------------------
+
+# FCM subcommands
+my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT
+ UPDATE SWITCH/;
+
+# Subcommands allowed when CWD is not a WC
+my @nwc_subcmds = qw/CHECKOUT BRANCH/;
+
+# Subcommands allowed, when CWD is a WC
+my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
+ SWITCH/;
+
+# Subcommands that apply to WC only
+my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
+ SWITCH/;
+
+# Subcommands that apply to top level WC only
+my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/;
+
+# Selected subcommand
+my $selsubcmd = '';
+
+# Selected subcommand is running?
+my $cmdrunning = 0;
+
+# PID of running subcommand
+my $cmdpid = undef;
+
+# List of subcommand frames
+my %subcmd_f;
+
+# List of subcommand buttons
+my %subcmd_b;
+
+# List of subcommand button help strings
+my %subcmd_help = (
+ BRANCH => 'list information about, create or delete a branch.',
+ CHECKOUT => 'check out a working copy from a repository.',
+ STATUS => 'print the status of working copy files and directories.',
+ DIFF => 'display the differences in modified files.',
+ ADD => 'put files and directories under version control.',
+ DELETE => 'remove files and directories from version control.',
+ MERGE => 'merge changes into your working copy.',
+ CONFLICTS => 'use a graphical tool to resolve conflicts in your working copy.',
+ COMMIT => 'send changes from your working copy to the repository.',
+ UPDATE => 'bring changes from the repository into your working copy.',
+ SWITCH => 'update your working copy to a different URL.',
+);
+
+for (keys %subcmd_help) {
+ $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' .
+ $subcmd_help{$_};
+}
+
+# List of subcommand button bindings (key name and underline position)
+my %subcmd_bind = (
+ BRANCH => {KEY => '', U => 0},
+ CHECKOUT => {KEY => '', U => 5},
+ STATUS => {KEY => '', U => 0},
+ DIFF => {KEY => '', U => 0},
+ ADD => {KEY => '', U => 0},
+ DELETE => {KEY => '', U => 4},
+ MERGE => {KEY => '', U => 0},
+ CONFLICTS => {KEY => '', U => 3},
+ COMMIT => {KEY => '', U => 0},
+ UPDATE => {KEY => '', U => 0},
+ SWITCH => {KEY => '', U => 1},
+);
+
+# List of subcommand variables
+my %subcmdvar = (
+ CWD => cwd (),
+ WCT => '',
+ CWD_URL => '',
+ WCT_URL => '',
+
+ BRANCH => {
+ OPT => 'info',
+ URL => '',
+ NAME => '',
+ TYPE => 'DEV',
+ REVFLAG => 'NORMAL',
+ REV => '',
+ TICKET => '',
+ SRCTYPE => 'trunk',
+ S_CHD => 0,
+ S_SIB => 0,
+ S_OTH => 0,
+ VERBOSE => 0,
+ OTHER => '',
+ },
+
+ CHECKOUT => {
+ URL => '',
+ REV => 'HEAD',
+ PATH => '',
+ OTHER => '',
+ },
+
+ STATUS => {
+ USEWCT => 0,
+ UPDATE => 0,
+ VERBOSE => 0,
+ OTHER => '',
+ },
+
+ DIFF => {
+ USEWCT => 0,
+ TOOL => 'graphical',
+ BRANCH => 0,
+ URL => '',
+ OTHER => '',
+ },
+
+ ADD => {
+ USEWCT => 0,
+ CHECK => 1,
+ OTHER => '',
+ },
+
+ DELETE => {
+ USEWCT => 0,
+ CHECK => 1,
+ OTHER => '',
+ },
+
+ MERGE => {
+ USEWCT => 1,
+ SRC => '',
+ MODE => 'automatic',
+ DRYRUN => 0,
+ VERBOSE => 0,
+ REV => '',
+ OTHER => '',
+ },
+
+ CONFLICTS => {
+ USEWCT => 0,
+ OTHER => '',
+ },
+
+ COMMIT => {
+ USEWCT => 1,
+ DRYRUN => 0,
+ OTHER => '',
+ },
+
+ UPDATE => {
+ USEWCT => 1,
+ OTHER => '',
+ },
+
+ SWITCH => {
+ USEWCT => 1,
+ URL => '',
+ OTHER => '',
+ },
+);
+
+# List of action buttons
+my %action_b;
+
+# List of action button help strings
+my %action_help = (
+ QUIT => 'Quit fcm gui',
+ HELP => 'Print help to the output text box for the selected sub-command',
+ CLEAR => 'Clear the output text box',
+ RUN => 'Run the selected sub-command',
+);
+
+# List of action button bindings
+my %action_bind = (
+ QUIT => {KEY => '', U => undef},
+ HELP => {KEY => '' , U => undef},
+ CLEAR => {KEY => '' , U => 1},
+ RUN => {KEY => '' , U => 0},
+);
+
+# List of branch subcommand options
+my %branch_opt = (
+ INFO => undef,
+ CREATE => undef,
+ DELETE => undef,
+ LIST => undef,
+);
+
+# List of branch create types
+my %branch_type = (
+ 'DEV' => undef,
+ 'DEV::SHARE' => undef,
+ 'TEST' => undef,
+ 'TEST::SHARE' => undef,
+ 'PKG' => undef,
+ 'PKG::SHARE' => undef,
+ 'PKG::CONFIG' => undef,
+ 'PKG::REL' => undef,
+);
+
+# List of branch create source type
+my %branch_srctype = (
+ TRUNK => undef,
+ BRANCH => undef,
+);
+
+# List of branch create revision prefix option
+my %branch_revflag = (
+ NORMAL => undef,
+ NUMBER => undef,
+ NONE => undef,
+);
+
+# List of branch info/delete options
+my %branch_info_opt = (
+ S_CHD => 'Show children',
+ S_SIB => 'Show siblings',
+ S_OTH => 'Show other',
+ VERBOSE => 'Print extra information',
+);
+
+# List of diff display options
+my %diff_display_opt = (
+ default => 'Default mode',
+ graphical => 'Graphical tool',
+ trac => 'Trac (only for diff relative to the base of the branch)',
+);
+
+# Text in the status bar
+my $statustext = '';
+
+# ------------------------------------------------------------------------------
+
+my $mw = MainWindow->new ();
+
+my $mw_title = 'FCM GUI';
+$mw->title ($mw_title);
+
+# Frame containing subcommand selection buttons
+my $top_f = $mw->Frame ()->grid (
+ '-row' => 0,
+ '-column' => 0,
+ '-sticky' => 'w',
+);
+
+# Frame containing subcommand options
+my $mid_f = $mw->Frame ()->grid (
+ '-row' => 1,
+ '-column' => 0,
+ '-sticky' => 'ew',
+);
+
+# Frame containing action buttons
+my $bot_f = $mw->Frame ()->grid (
+ '-row' => 2,
+ '-column' => 0,
+ '-sticky' => 'ew',
+);
+
+# Text box to display output
+my $out_t = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
+ '-row' => 3,
+ '-column' => 0,
+ '-sticky' => 'news',
+);
+
+# Text box - allow scroll with mouse wheel
+$out_t->bind (
+ '<4>' => sub {
+ $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
+ },
+);
+
+$out_t->bind (
+ '<5>' => sub {
+ $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
+ },
+);
+
+# Status bar
+$mw->Label (
+ '-textvariable' => \$statustext,
+ '-relief' => 'groove',
+)->grid (
+ '-row' => 4,
+ '-column' => 0,
+ '-sticky' => 'ews',
+);
+
+# Main window grid configure
+{
+ my ($cols, $rows) = $mw->gridSize ();
+ $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
+ $mw->gridRowconfigure ( 3, '-weight' => 1);
+}
+
+# Frame grid configure
+{
+ my ($cols, $rows) = $mid_f->gridSize ();
+ $bot_f->gridColumnconfigure (3, '-weight' => 1);
+}
+
+$mid_f->gridRowconfigure (0, '-weight' => 1);
+$mid_f->gridColumnconfigure (0, '-weight' => 1);
+
+# ------------------------------------------------------------------------------
+
+# Buttons to select subcommands
+{
+ my $col = 0;
+ for my $name (@subcmds) {
+ $subcmd_b{$name} = $top_f->Button (
+ '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
+ '-command' => [\&button_clicked, $name],
+ '-width' => 8,
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+
+ $subcmd_b{$name}->bind ('', sub {$statustext = $subcmd_help{$name}});
+ $subcmd_b{$name}->bind ('', sub {$statustext = ''});
+
+ $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
+ if defined $subcmd_bind{$name}{U};
+
+ $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
+ }
+}
+
+# ------------------------------------------------------------------------------
+
+# Frames to contain subcommands options
+{
+ my %row = ();
+
+ for my $name (@subcmds) {
+ $subcmd_f{$name} = $mid_f->Frame ();
+ $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);
+
+ $row{$name} = 0;
+
+ # Widgets common to all sub-commands
+ $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+ }
+
+ # Widgets common to all sub-commands that apply to working copies
+ for my $name (@wco_subcmds) {
+ my @labtxts = (
+ 'Corresponding URL: ',
+ 'Working copy top: ',
+ 'Corresponding URL: ',
+ );
+ my @varrefs = \(
+ $subcmdvar{URL_CWD},
+ $subcmdvar{WCT},
+ $subcmdvar{URL_WCT},
+ );
+
+ for my $i (0 .. $#varrefs) {
+ $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+ }
+
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Apply sub-command to working copy top',
+ '-variable' => \($subcmdvar{$name}{USEWCT}),
+ '-state' => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+ }
+
+ # Widget for the Branch sub-command
+ {
+ my $name = 'BRANCH';
+
+ # Radio buttons to select the sub-option of the branch sub-command
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (sort keys %branch_opt) {
+ my $opt = lc $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $opt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{OPT}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+
+ # Label and entry box for specifying URL
+ $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{URL}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+
+ # Label and entry box for specifying create branch name
+ $subcmd_f{$name}->Label (
+ '-text' => 'Branch name (create only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{NAME}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+
+ # Label and entry box for specifying create branch source revision
+ $subcmd_f{$name}->Label (
+ '-text' => 'Source revision (create/list only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{REV}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+
+ # Label and radio buttons box for specifying create branch type
+ $subcmd_f{$name}->Label (
+ '-text' => 'Branch type (create only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (sort keys %branch_type) {
+ my $txt = lc $key;
+ my $opt = $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $txt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{TYPE}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ # Label and radio buttons box for specifying create source type
+ $subcmd_f{$name}->Label (
+ '-text' => 'Source type (create only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (sort keys %branch_srctype) {
+ my $txt = lc $key;
+ my $opt = lc $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $txt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{SRCTYPE}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ # Label and radio buttons box for specifying create prefix option
+ $subcmd_f{$name}->Label (
+ '-text' => 'Prefix option (create only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (sort keys %branch_revflag) {
+ my $txt = lc $key;
+ my $opt = $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $txt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{REVFLAG}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ # Label and entry box for specifying ticket number
+ $subcmd_f{$name}->Label (
+ '-text' => 'Related Trac ticket(s) (create only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{TICKET}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+
+ # Check button for info/delete
+ # --show-children, --show-siblings, --show-other, --verbose
+ $subcmd_f{$name}->Label (
+ '-text' => 'Options for info/delete only: ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+
+ for my $key (sort keys %branch_info_opt) {
+ $opt_f->Checkbutton (
+ '-text' => $branch_info_opt{$key},
+ '-variable' => \($subcmdvar{$name}{$key}),
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+ }
+
+ # Widget for the Checkout sub-command
+ {
+ my $name = 'CHECKOUT';
+
+ # Label and entry boxes for specifying URL and revision
+ my @labtxts = (
+ 'URL: ',
+ 'Revision: ',
+ 'Path: ',
+ );
+ my @varrefs = \(
+ $subcmdvar{$name}{URL},
+ $subcmdvar{$name}{REV},
+ $subcmdvar{$name}{PATH},
+ );
+
+ for my $i (0 .. $#varrefs) {
+ $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => $varrefs[$i],
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+ }
+ }
+
+ # Widget for the Status sub-command
+ {
+ my $name = 'STATUS';
+
+ # Checkbuttons for various options
+ my @labtxts = (
+ 'Display update information',
+ 'Print extra information',
+ );
+ my @varrefs = \(
+ $subcmdvar{$name}{UPDATE},
+ $subcmdvar{$name}{VERBOSE},
+ );
+
+ for my $i (0 .. $#varrefs) {
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => $labtxts[$i],
+ '-variable' => $varrefs[$i],
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ # Widget for the Diff sub-command
+ {
+ my $name = 'DIFF';
+
+ my $entry;
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Show differences relative to the base of the branch',
+ '-variable' => \($subcmdvar{$name}{BRANCH}),
+ '-command' => sub {
+ $entry->configure (
+ '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
+ );
+ },
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+
+ # Label and radio buttons box for specifying tool
+ $subcmd_f{$name}->Label (
+ '-text' => 'Display diff in: ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (qw/default graphical trac/) {
+ my $txt = $diff_display_opt{$key};
+ my $opt = $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $txt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{TOOL}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ $entry = $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{URL}),
+ '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+ }
+
+ # Widget for the Add/Delete sub-command
+ for my $name (qw/ADD DELETE/) {
+
+ # Checkbuttons for various options
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Check for files or directories not under version control',
+ '-variable' => \($subcmdvar{$name}{CHECK}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+ }
+
+ # Widget for the Merge sub-command
+ {
+ my $name = 'MERGE';
+
+ # Label and radio buttons box for specifying merge mode
+ $subcmd_f{$name}->Label (
+ '-text' => 'Mode: ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+
+ {
+ my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'w',
+ );
+
+ my $col = 0;
+ for my $key (qw/automatic custom reverse/) {
+ my $txt = lc $key;
+ my $opt = $key;
+
+ $branch_opt{$key} = $opt_f->Radiobutton (
+ '-text' => $txt,
+ '-value' => $opt,
+ '-variable' => \($subcmdvar{$name}{MODE}),
+ '-state' => 'normal',
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => 'w',
+ );
+ }
+ }
+
+ # Check buttons for dry-run
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Dry run',
+ '-variable' => \($subcmdvar{$name}{DRYRUN}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+
+ # Check buttons for verbose mode
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Print extra information',
+ '-variable' => \($subcmdvar{$name}{VERBOSE}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+
+ # Label and entry boxes for specifying merge source
+ $subcmd_f{$name}->Label (
+ '-text' => 'Source (automatic/custom only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{SRC}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+
+ # Label and entry boxes for specifying merge revision (range)
+ $subcmd_f{$name}->Label (
+ '-text' => 'Revision (custom/reverse only): ',
+ )->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{REV}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+ }
+
+ # Widget for the Commit sub-command
+ {
+ my $name = 'COMMIT';
+
+ # Checkbuttons for various options
+ $subcmd_f{$name}->Checkbutton (
+ '-text' => 'Dry run',
+ '-variable' => \($subcmdvar{$name}{DRYRUN}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 0,
+ '-columnspan' => 2,
+ '-sticky' => 'w',
+ );
+ }
+
+ # Widget for the Switch sub-command
+ {
+ my $name = 'SWITCH';
+
+ # Label and entry boxes for specifying switch URL
+ $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{URL}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+ }
+
+ # Widgets common to all sub-commands
+ for my $name (@subcmds) {
+ $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid (
+ '-row' => $row{$name},
+ '-column' => 0,
+ '-sticky' => 'w',
+ );
+ $subcmd_f{$name}->Entry (
+ '-textvariable' => \($subcmdvar{$name}{OTHER}),
+ )->grid (
+ '-row' => $row{$name}++,
+ '-column' => 1,
+ '-sticky' => 'ew',
+ );
+ }
+}
+
+# ------------------------------------------------------------------------------
+
+# Buttons to perform main actions
+{
+ my $col = 0;
+ for my $name (qw/QUIT HELP CLEAR RUN/) {
+ $action_b{$name} = $bot_f->Button (
+ '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
+ '-command' => [\&button_clicked, $name],
+ '-width' => 8,
+ )->grid (
+ '-row' => 0,
+ '-column' => $col++,
+ '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'),
+ );
+
+ $action_b{$name}->bind ('', sub {$statustext = $action_help{$name}});
+ $action_b{$name}->bind ('', sub {$statustext = ''});
+
+ $action_b{$name}->configure ('-underline' => $action_bind{$name}{U})
+ if defined $action_bind{$name}{U};
+
+ $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke});
+ }
+}
+
+&change_cwd ($subcmdvar{CWD});
+
+# ------------------------------------------------------------------------------
+
+# Handle the situation when the user attempts to quit the window while a
+# sub-command is running
+
+$mw->protocol ('WM_DELETE_WINDOW', sub {
+ if (defined $cmdpid) {
+ my $ans = $mw->messageBox (
+ '-title' => $mw_title,
+ '-message' => $selsubcmd . ' is still running. Really quit?',
+ '-type' => 'YesNo',
+ '-default' => 'No',
+ );
+
+ if ($ans eq 'Yes') {
+ kill 9, $cmdpid; # Need to kill the sub-process before quitting
+
+ } else {
+ return; # Do not quit
+ }
+ }
+
+ exit;
+});
+
+MainLoop;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# &change_cwd ($dir);
+#
+# DESCRIPTION
+# Change current working directory to $dir
+# ------------------------------------------------------------------------------
+
+sub change_cwd {
+ my $dir = $_[0];
+ my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds);
+
+ for my $subcmd (@subcmds) {
+ if (grep {$_ eq $subcmd} @allowed_subcmds) {
+ $subcmd_b{$subcmd}->configure ('-state' => 'normal');
+
+ } else {
+ $subcmd_b{$subcmd}->configure ('-state' => 'disabled');
+ }
+ }
+
+ &display_subcmd_frame ($allowed_subcmds[0])
+ if not grep {$_ eq $selsubcmd} @allowed_subcmds;
+
+ chdir $dir;
+ $subcmdvar{CWD} = $dir;
+
+ if (&is_wc ($dir)) {
+ $subcmdvar{WCT} = &get_wct ($dir);
+ $subcmdvar{URL_CWD} = &get_url_of_wc ($dir);
+ $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT});
+
+ $branch_opt{INFO} ->configure ('-state' => 'normal');
+ $branch_opt{DELETE}->configure ('-state' => 'normal');
+ $subcmdvar{BRANCH}{OPT} = 'info';
+
+ } else {
+ $branch_opt{INFO} ->configure ('-state' => 'disabled');
+ $branch_opt{DELETE}->configure ('-state' => 'disabled');
+ $subcmdvar{BRANCH}{OPT} = 'create';
+ }
+
+ return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# &button_clicked ($name);
+#
+# DESCRIPTION
+# Call back function to handle a click on a command button named $name.
+# ------------------------------------------------------------------------------
+
+sub button_clicked {
+ my $name = $_[0];
+
+ if (grep {$_ eq $name} keys %subcmd_b) {
+ &display_subcmd_frame ($name);
+
+ } elsif ($name eq 'CLEAR') {
+ $out_t->delete ('1.0', 'end');
+
+ } elsif ($name eq 'QUIT') {
+ exit;
+
+ } elsif ($name eq 'HELP') {
+ &invoke_cmd ('help ' . lc ($selsubcmd));
+
+ } elsif ($name eq 'RUN') {
+ &invoke_cmd (&setup_cmd ($selsubcmd));
+
+ } else {
+ $out_t->insert ('end', $name . ': function to be implemented' . "\n");
+ $out_t->yviewMoveto (1);
+ }
+
+ return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# &display_subcmd_frame ($name);
+#
+# DESCRIPTION
+# Change selected subcommand to $name, and display the frame containing the
+# widgets for configuring the options and arguments of that subcommand.
+# ------------------------------------------------------------------------------
+
+sub display_subcmd_frame {
+ my $name = $_[0];
+
+ if ($selsubcmd ne $name and not $cmdrunning) {
+ $subcmd_b{$name }->configure ('-relief' => 'sunken');
+ $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd;
+
+ $subcmd_f{$name }->grid ('-sticky' => 'new');
+ $subcmd_f{$selsubcmd}->gridForget if $selsubcmd;
+
+ $selsubcmd = $name;
+ }
+
+ return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $pos = &get_wm_pos ();
+#
+# DESCRIPTION
+# Returns the position part of the geometry string of the main window.
+# ------------------------------------------------------------------------------
+
+sub get_wm_pos {
+ my $geometry = $mw->geometry ();
+ $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/;
+ return $1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $command = &setup_cmd ($name);
+#
+# DESCRIPTION
+# Setup the the system command for the sub-command $name.
+# ------------------------------------------------------------------------------
+
+sub setup_cmd {
+ my $name = $_[0];
+ my $cmd = '';
+
+ if ($name eq 'BRANCH') {
+ $cmd .= lc ($name);
+ if ($subcmdvar{$name}{OPT} eq 'create') {
+ $cmd .= ' -c --svn-non-interactive';
+ $cmd .= ' -n ' . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME};
+ $cmd .= ' -t ' . $subcmdvar{$name}{TYPE};
+ $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
+ $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+ $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
+ $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';
+
+ } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
+ $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+ $cmd .= ' -d --svn-non-interactive';
+
+ } elsif ($subcmdvar{$name}{OPT} eq 'list') {
+ $cmd .= ' -l';
+ $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+
+ } else {
+ $cmd .= ' -i';
+ $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
+ $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
+ $cmd .= ' --show-other' if $subcmdvar{$name}{S_OTH};
+ $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+ }
+ $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'CHECKOUT') {
+ $cmd .= lc ($name);
+ $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+ $cmd .= ' ' . $subcmdvar{$name}{URL};
+ $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};
+
+ } elsif ($name eq 'STATUS') {
+ $cmd .= lc ($name);
+ $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
+ $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'DIFF') {
+ $cmd .= lc ($name);
+ $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical';
+
+ if ($subcmdvar{$name}{BRANCH}) {
+ $cmd .= ' -b';
+ $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac';
+ $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
+ }
+
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'ADD' or $name eq 'DELETE') {
+ $cmd .= lc ($name);
+ $cmd .= ' -c' if $subcmdvar{$name}{CHECK};
+ $cmd .= ' --non-interactive'
+ if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'MERGE') {
+ $cmd .= lc ($name);
+
+ if ($subcmdvar{$name}{MODE} ne 'automatic') {
+ $cmd .= ' --' . $subcmdvar{$name}{MODE};
+ $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+ }
+
+ $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
+ $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+ $cmd .= ' ' . $subcmdvar{$name}{SRC} if $subcmdvar{$name}{SRC};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'CONFLICTS') {
+ $cmd .= lc ($name);
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'COMMIT') {
+ $cmd .= lc ($name);
+ $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
+ $cmd .= ' --svn-non-interactive';
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'SWITCH') {
+ $cmd .= lc ($name);
+ $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ } elsif ($name eq 'UPDATE') {
+ $cmd .= lc ($name);
+ $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+ }
+
+ return $cmd;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# &invoke_cmd ($cmd);
+#
+# DESCRIPTION
+# Invoke the command $cmd.
+# ------------------------------------------------------------------------------
+
+sub invoke_cmd {
+ my $cmd = $_[0];
+ return unless $cmd;
+
+ my $disp_cmd = 'fcm ' . $cmd;
+ $cmd = (index ($cmd, 'help ') == 0)
+ ? $disp_cmd
+ : ('fcm gui-internal ' . &get_wm_pos () . ' ' . $cmd);
+
+ # Change directory to working copy top if necessary
+ if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) {
+ chdir $subcmdvar{WCT};
+ $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n");
+ $out_t->yviewMoveto (1);
+ }
+
+ # Report start of command
+ $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start'));
+ $out_t->yviewMoveto (1);
+
+ # Open the command as a pipe
+ if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') {
+ # Disable all action buttons
+ $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b);
+ $cmdrunning = 1;
+
+ # Set up a file event to read output from the command
+ $mw->fileevent (\*CMD, readable => sub {
+ if (sysread CMD, my ($buf), 1024) {
+ # Insert text into the output text box as it becomes available
+ $out_t->insert ('end', $buf);
+ $out_t->yviewMoveto (1);
+
+ } else {
+ # Delete the file event and close the file when the command finishes
+ $mw->fileevent(\*CMD, readable => '');
+ close CMD;
+ $cmdpid = undef;
+
+ # Check return status
+ if ($?) {
+ $out_t->insert (
+ 'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n",
+ );
+ $out_t->yviewMoveto (1);
+ }
+
+ # Report end of command
+ $out_t->insert ('end', timestamp_command ($disp_cmd, 'End'));
+ $out_t->yviewMoveto (1);
+
+ # Change back to CWD if necessary
+ if ($subcmdvar{$selsubcmd}{USEWCT} and
+ $subcmdvar{WCT} ne $subcmdvar{CWD}) {
+ chdir $subcmdvar{CWD};
+ $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n");
+ $out_t->yviewMoveto (1);
+ }
+
+ # Enable all action buttons again
+ $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b);
+ $cmdrunning = 0;
+
+ # If the command is "checkout", change directory to working copy
+ if (lc ($selsubcmd) eq 'checkout' && $subcmdvar{CHECKOUT}{URL}) {
+ my $url = Fcm::Keyword::expand($subcmdvar{CHECKOUT}{URL});
+ my $dir = $subcmdvar{CHECKOUT}{PATH}
+ ? $subcmdvar{CHECKOUT}{PATH}
+ : basename $url;
+ $dir = File::Spec->rel2abs ($dir);
+ &change_cwd ($dir);
+
+ # If the command is "switch", change URL
+ } elsif (lc ($selsubcmd) eq 'switch') {
+ $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1);
+ $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1);
+ }
+ }
+ 1;
+ });
+
+ } else {
+ $mw->messageBox (
+ '-title' => 'Error',
+ '-message' => 'Error running "' . $cmd . '"',
+ '-icon' => 'error',
+ );
+ }
+
+ return;
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
+
+=head1 NAME
+
+fcm_gui
+
+=head1 SYNOPSIS
+
+fcm_gui [DIR]
+
+=head1 DESCRIPTION
+
+The fcm_gui command is a simple graphical user interface for some of the
+commands of the FCM system. The optional argument DIR modifies the initial
+working directory.
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/bin/fcm_internal
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_internal (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_internal (revision 9596)
@@ -0,0 +1,615 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use Fcm::Timer qw{timestamp_command};
+
+# Function declarations
+sub catfile;
+sub basename;
+sub dirname;
+
+# ------------------------------------------------------------------------------
+
+# Module level variables
+my %unusual_tool_name = ();
+
+# ------------------------------------------------------------------------------
+
+MAIN: {
+ # Name of program
+ my $this = basename $0;
+
+ # Arguments
+ my $subcommand = shift @ARGV;
+ my ($function, $type) = split /:/, $subcommand;
+
+ my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata);
+
+ if ($function eq 'archive') {
+ ($target, @objects) = @ARGV;
+
+ } elsif ($function eq 'load') {
+ ($srcpackage, $src, $target, @blockdata) = @ARGV;
+
+ } else {
+ ($srcpackage, $src, $target, $requirepp) = @ARGV;
+ }
+
+ # Set up hash reference for all the required information
+ my %info = (
+ SRCPACKAGE => $srcpackage,
+ SRC => $src,
+ TYPE => $type,
+ TARGET => $target,
+ REQUIREPP => $requirepp,
+ OBJECTS => \@objects,
+ BLOCKDATA => \@blockdata,
+ );
+
+ # Get list of unusual tools
+ my $i = 0;
+ while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) {
+ my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i);
+ $unusual_tool_name{$label} = $value;
+ $i++;
+ }
+
+ # Invoke the action
+ my $rc = 0;
+ if ($function eq 'compile') {
+ $rc = &compile (\%info);
+
+ } elsif ($function eq 'load') {
+ $rc = &load (\%info);
+
+ } elsif ($function eq 'archive') {
+ $rc = &archive (\%info);
+
+ } else {
+ print STDERR $this, ': incorrect usage, abort';
+ $rc = 1;
+ }
+
+ # Throw error if action failed
+ if ($rc) {
+ print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n";
+ exit 1;
+
+ } else {
+ exit;
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = &compile (\%info);
+#
+# DESCRIPTION
+# This method invokes the correct compiler with the correct options to
+# compile the source file into the required target. The argument $info is a
+# hash reference set up in MAIN. The following environment variables are
+# used, where * is the source file type (F for Fortran, and C for C/C++):
+#
+# *C - compiler command
+# *C_OUTPUT - *C option to specify the name of the output file
+# *C_DEFINE - *C option to declare a pre-processor def
+# *C_INCLUDE - *C option to declare an include directory
+# *C_MODSEARCH- *C option to declare a module search directory
+# *C_COMPILE - *C option to ask the compiler to perform compile only
+# *CFLAGS - *C user options
+# *PPKEYS - list of pre-processor defs (may have sub-package suffix)
+# FCM_VERBOSE - verbose level
+# FCM_OBJDIR - destination directory of object file
+# FCM_TMPDIR - temporary destination directory of object file
+# ------------------------------------------------------------------------------
+
+sub compile {
+ my $info = shift;
+
+ # Verbose mode
+ my $verbose = &get_env ('FCM_VERBOSE');
+ $verbose = 1 unless defined ($verbose);
+
+ my @command = ();
+
+ # Guess file type for backward compatibility
+ my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC});
+
+ # Compiler
+ push @command, &get_env ($type . 'C', 1);
+
+ # Compile output target (typical -o option)
+ push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET};
+
+ # Pre-processor definition macros
+ if ($info->{REQUIREPP}) {
+ my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS');
+ my $defopt = &get_env ($type . 'C_DEFINE', 1);
+
+ push @command, (map {$defopt . $_} @ppkeys);
+ }
+
+ # Include search path
+ my $incopt = &get_env ($type . 'C_INCLUDE', 1);
+ my @incpath = split /:/, &get_env ('FCM_INCPATH');
+ push @command, (map {$incopt . $_} @incpath);
+
+ # Compiled module search path
+ my $modopt = &get_env ($type . 'C_MODSEARCH');
+ if ($modopt) {
+ push @command, (map {$modopt . $_} @incpath);
+ }
+
+ # Other compiler flags
+ my $flags = &select_flags ($info, $type . 'FLAGS');
+ push @command, $flags if $flags;
+
+ my $compile_only = &get_env ($type . 'C_COMPILE');
+ if ($flags !~ /(?:^|\s)$compile_only\b/) {
+ push @command, &get_env ($type . 'C_COMPILE');
+ }
+
+ # Name of source file
+ push @command, $info->{SRC};
+
+ # Execute command
+ my $objdir = &get_env ('FCM_OBJDIR', 1);
+ my $tmpdir = &get_env ('FCM_TMPDIR', 1);
+ chdir $tmpdir;
+
+ my $command = join ' ', @command;
+ if ($verbose > 1) {
+ print 'cd ', $tmpdir, "\n";
+ print ×tamp_command ($command, 'Start');
+
+ } elsif ($verbose) {
+ print $command, "\n";
+ }
+
+ my $rc = system $command;
+
+ print ×tamp_command ($command, 'End ') if $verbose > 1;
+
+ # Move temporary output to correct location on success
+ # Otherwise, remove temporary output
+ if ($rc) { # error
+ unlink $info->{TARGET};
+
+ } else { # success
+ print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1;
+ rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET});
+ }
+
+ # Move any Fortran module definition files to the INC directory
+ my @modfiles = <*.mod *.MOD>;
+ for my $file (@modfiles) {
+ rename $file, &catfile ($incpath[0], $file);
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = &load (\%info);
+#
+# DESCRIPTION
+# This method invokes the correct loader with the correct options to link
+# the main program object into an executable. The argument $info is a hash
+# reference set up in MAIN. The following environment variables are used:
+#
+# LD - * linker command
+# LD_OUTPUT - LD option to specify the name of the output file
+# LD_LIBSEARCH - LD option to declare a directory in the library search path
+# LD_LIBLINK - LD option to declare an object library
+# LDFLAGS - LD user options
+# FCM_VERBOSE - verbose level
+# FCM_LIBDIR - destination directory of object libraries
+# FCM_OBJDIR - destination directory of object files
+# FCM_BINDIR - destination directory of executable file
+# FCM_TMPDIR - temporary destination directory of executable file
+#
+# * If LD is not set, it will attempt to guess the file type and use the
+# compiler as the linker.
+# ------------------------------------------------------------------------------
+
+sub load {
+ my $info = shift;
+
+ my $rc = 0;
+
+ # Verbose mode
+ my $verbose = &get_env ('FCM_VERBOSE');
+ $verbose = 1 unless defined ($verbose);
+
+ # Create temporary object library
+ (my $name = $info->{TARGET}) =~ s/\.\S+$//;
+ my $libname = '__fcm__' . $name;
+ my $lib = 'lib' . $libname . '.a';
+ my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib);
+ $rc = &archive ({TARGET => $lib});
+
+ unless ($rc) {
+ my @command = ();
+
+ # Linker
+ my $ld = &select_flags ($info, 'LD');
+ if (not $ld) {
+ # Guess file type for backward compatibility
+ my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC});
+ $ld = &get_env ($type . 'C', 1);
+ }
+ push @command, $ld;
+
+ # Linker output target (typical -o option)
+ push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET};
+
+ # Name of main object file
+ my $mainobj = (basename ($info->{SRC}) eq $info->{SRC})
+ ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC})
+ : $info->{SRC};
+ push @command, $mainobj;
+
+ # Link with Fortran BLOCKDATA objects if necessary
+ if (@{ $info->{BLOCKDATA} }) {
+ my @blockdata = @{ $info->{BLOCKDATA} };
+ my @objpath = split /:/, &get_env ('FCM_OBJPATH');
+
+ # Search each BLOCKDATA object file from the object search path
+ for my $file (@blockdata) {
+ for my $dir (@objpath) {
+ my $full = catfile ($dir, $file);
+
+ if (-r $full) {
+ $file = $full;
+ last;
+ }
+ }
+
+ push @command, $file;
+ }
+ }
+
+ # Library search path
+ my $libopt = &get_env ('LD_LIBSEARCH', 1);
+ my @libpath = split /:/, &get_env ('FCM_LIBPATH');
+ push @command, (map {$libopt . $_} @libpath);
+
+ # Link with temporary object library if it exists
+ push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile;
+
+ # Other linker flags
+ my $flags = &select_flags ($info, 'LDFLAGS');
+ push @command, $flags;
+
+ # Execute command
+ my $tmpdir = &get_env ('FCM_TMPDIR', 1);
+ my $bindir = &get_env ('FCM_BINDIR', 1);
+ chdir $tmpdir;
+
+ my $command = join ' ', @command;
+ if ($verbose > 1) {
+ print 'cd ', $tmpdir, "\n";
+ print ×tamp_command ($command, 'Start');
+
+ } elsif ($verbose) {
+ print $command, "\n";
+ }
+
+ $rc = system $command;
+
+ print ×tamp_command ($command, 'End ') if $verbose > 1;
+
+ # Move temporary output to correct location on success
+ # Otherwise, remove temporary output
+ if ($rc) { # error
+ unlink $info->{TARGET};
+
+ } else { # success
+ print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1;
+ rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET});
+ }
+ }
+
+ # Remove the temporary object library
+ unlink $libfile if -f $libfile;
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = &archive (\%info);
+#
+# DESCRIPTION
+# This method invokes the library archiver to create an object library. The
+# argument $info is a hash reference set up in MAIN. The following
+# environment variables are used:
+#
+# AR - archiver command
+# ARFLAGS - AR options to update/create an object library
+# FCM_VERBOSE - verbose level
+# FCM_LIBDIR - destination directory of object libraries
+# FCM_OBJPATH - search path of object files
+# FCM_OBJDIR - destination directory of object files
+# FCM_TMPDIR - temporary destination directory of executable file
+# ------------------------------------------------------------------------------
+
+sub archive {
+ my $info = shift;
+
+ my $rc = 0;
+
+ # Verbose mode
+ my $verbose = &get_env ('FCM_VERBOSE');
+ $verbose = 1 unless defined ($verbose);
+
+ # Set up the archive command
+ my $lib = &basename ($info->{TARGET});
+ my $tmplib = &catfile (&get_env ('FCM_TMPDIR', 1), $lib);
+ my @ar_cmd = ();
+ push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1));
+ push @ar_cmd, $tmplib;
+
+ # Get object directories and their files
+ my %objdir;
+ if (exists $info->{OBJECTS}) {
+ # List of objects set in the argument, sort into directory/file list
+ for my $name (@{ $info->{OBJECTS} }) {
+ my $dir = (&dirname ($name) eq '.')
+ ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name);
+ $objdir{$dir}{&basename ($name)} = 1;
+ }
+
+ } else {
+ # Objects not listed in argument, search object path for all files
+ my @objpath = split /:/, &get_env ('FCM_OBJPATH', 1);
+ my %objbase = ();
+
+ # Get registered objects into a hash (keys = objects, values = 1)
+ my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS'));
+
+ # Seach object path for all files
+ for my $dir (@objpath) {
+ next unless -d $dir;
+
+ chdir $dir;
+
+ # Use all files from each directory in the object search path
+ for ((glob ('*'))) {
+ next unless exists $objects{$_}; # consider registered objects only
+ $objdir{$dir}{$_} = 1 unless exists $objbase{$_};
+ $objbase{$_} = 1;
+ }
+ }
+ }
+
+ for my $dir (sort keys %objdir) {
+ next unless -d $dir;
+
+ # Go to each object directory and executes the library archive command
+ chdir $dir;
+ my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} });
+
+ if ($verbose > 1) {
+ print 'cd ', $dir, "\n";
+ print ×tamp_command ($command, 'Start');
+
+ } else {
+ print $command, "\n" if exists $info->{OBJECTS};
+ }
+
+ $rc = system $command;
+
+ print ×tamp_command ($command, 'End ')
+ if $verbose > 1;
+ last if $rc;
+ }
+
+ # Move temporary output to correct location on success
+ # Otherwise, remove temporary output
+ if ($rc) { # error
+ unlink $tmplib;
+
+ } else { # success
+ my $libdir = &get_env ('FCM_LIBDIR', 1);
+
+ print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1;
+ rename $tmplib, &catfile ($libdir, $lib);
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $type = &guess_file_type ($filename);
+#
+# DESCRIPTION
+# This function attempts to guess the file type by looking at the extension
+# of the $filename. Only C and Fortran at the moment.
+# ------------------------------------------------------------------------------
+
+sub guess_file_type {
+ return (($_[0] =~ /\.c(\w+)?$/i) ? 'C' : 'F');
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $flags = &select_flags (\%info, $set);
+#
+# DESCRIPTION
+# This function selects the correct compiler/linker flags for the current
+# sub-package from the environment variable prefix $set. The argument $info
+# is a hash reference set up in MAIN.
+# ------------------------------------------------------------------------------
+
+sub select_flags {
+ my ($info, $set) = @_;
+
+ my $srcbase = &basename ($info->{SRC});
+ my @names = ($set);
+ push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcbase);
+
+ my $string = '';
+ for my $i (reverse (0 .. $#names)) {
+ my $var = &get_env (join ('__', (@names[0 .. $i])));
+
+ $var = &get_env (join ('__', (@names[0 .. $i])))
+ if (not defined ($var)) and $i and $names[-1] =~ s/\.[^\.]+$//;
+
+ next unless defined $var;
+ $string = $var;
+ last;
+ }
+
+ return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $variable = &get_env ($name);
+# $variable = &get_env ($name, $compulsory);
+#
+# DESCRIPTION
+# This internal method gets a variable from $ENV{$name}. If $compulsory is
+# set to true, it throws an error if the variable is a not set or is an empty
+# string. Otherwise, it returns C if the variable is not set.
+# ------------------------------------------------------------------------------
+
+sub get_env {
+ (my $name, my $compulsory) = @_;
+ my $string;
+
+ if ($name =~ /^\w+$/) {
+ # $name contains only word characters, variable is exported normally
+ die 'The environment variable "', $name, '" must be set, abort'
+ if $compulsory and not exists $ENV{$name};
+
+ $string = exists $ENV{$name} ? $ENV{$name} : undef;
+
+ } else {
+ # $name contains unusual characters
+ die 'The environment variable "', $name, '" must be set, abort'
+ if $compulsory and not exists $unusual_tool_name{$name};
+
+ $string = exists $unusual_tool_name{$name}
+ ? $unusual_tool_name{$name} : undef;
+ }
+
+ return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $path = &catfile (@paths);
+#
+# DESCRIPTION
+# This is a local implementation of what is in the File::Spec module.
+# ------------------------------------------------------------------------------
+
+sub catfile {
+ my @names = split (m!/!, join ('/', @_));
+ my $path = shift @names;
+
+ for my $name (@names) {
+ $path .= '/' . $name if $name;
+ }
+
+ return $path;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $basename = &basename ($path);
+#
+# DESCRIPTION
+# This is a local implementation of what is in the File::Basename module.
+# ------------------------------------------------------------------------------
+
+sub basename {
+ my $name = $_[0];
+
+ $name =~ s{/*$}{}; # remove trailing slashes
+
+ if ($name =~ m#.*/([^/]+)$#) {
+ return $1;
+
+ } else {
+ return $name;
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $dirname = &dirname ($path);
+#
+# DESCRIPTION
+# This is a local implementation of what is in the File::Basename module.
+# ------------------------------------------------------------------------------
+
+sub dirname {
+ my $name = $_[0];
+
+ if ($name =~ m#^/+$#) {
+ return '/'; # dirname of root is root
+
+ } else {
+ $name =~ s{/*$}{}; # remove trailing slashes
+
+ if ($name =~ m#^(.*)/[^/]+$#) {
+ my $dir = $1;
+ $dir =~ s{/*$}{}; # remove trailing slashes
+ return $dir;
+
+ } else {
+ return '.';
+ }
+ }
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
+
+=head1 NAME
+
+fcm_internal
+
+=head1 SYNOPSIS
+
+ fcm_internal SUBCOMMAND ARGS
+
+=head1 DESCRIPTION
+
+The fcm_internal command is a frontend for some of the internal commands of
+the FCM build system. The subcommand can be "compile", "load" or "archive"
+for invoking the compiler, loader and library archiver respectively. If
+"compile" or "load" is specified, it can be suffixed with ":TYPE" to
+specify the nature of the source file. If TYPE is not specified, it is set
+to C if the file extension begins with ".c". For all other file types, it
+is set to F (for Fortran source). For compile and load, the other arguments
+are 1) the name of the container package of the source file, 2) the path to
+the source file and 3) the target name after compiling or loading the
+source file. For compile, the 4th argument is a flag to indicate whether
+pre-processing is required for compiling the source file. For load, the
+4th and the rest of the arguments is a list of object files that cannot be
+archived into the temporary load library and must be linked into the target
+through the linker command. (E.g. Fortran BLOCKDATA program units must be
+linked this way.) If archive is specified, the first argument should be the
+name of the library archive target and the rest should be the object files
+to be included in the archive. This command is invoked via the build system
+and should never be called directly by the user.
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/bin/fcm_setup_konqueror
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_setup_konqueror (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_setup_konqueror (revision 9596)
@@ -0,0 +1,47 @@
+#!/bin/sh
+# ------------------------------------------------------------------------------
+# NAME
+# fcm_setup_konqueror
+#
+# SYNOPSIS
+# fcm_setup_konqueror
+#
+# DESCRIPTION
+# Set up Konqueror to use "fcm gui".
+#
+# COPYRIGHT
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Check number of arguments
+script=`basename $0`
+usage="$script: no argument required"
+if (( $# != 0 )); then
+ echo "$usage, abort..." >&2
+ exit 1
+fi
+
+filename=fcm_gui.desktop
+
+file=`dirname $0`
+if [[ `basename $file` = bin ]]; then
+ file=`dirname $file`
+fi
+file=$file/etc/$filename
+
+if [[ ! -f $file ]]; then
+ echo "$script: $file not found, abort..." >&2
+ exit 1
+fi
+
+dir=$HOME/.kde/share/applnk/.hidden
+mkdir -p $dir
+cd $dir
+rm -f $filename # Always remove.
+ln -s $file .
+
+echo "$script: finished"
+
+#EOF
Index: NEMO/trunk/ext/FCM/bin/fcm_update_version_dir.pl
===================================================================
--- NEMO/trunk/ext/FCM/bin/fcm_update_version_dir.pl (revision 9596)
+++ NEMO/trunk/ext/FCM/bin/fcm_update_version_dir.pl (revision 9596)
@@ -0,0 +1,289 @@
+#!/usr/bin/env perl
+#-------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+#-------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use Cwd qw{cwd};
+use Getopt::Long qw{GetOptions};
+use Fcm::Config;
+use Fcm::Keyword;
+use Fcm::Util qw{get_url_of_wc get_wct is_wc run_command tidy_url};
+use File::Basename qw{basename dirname};
+use File::Path qw{mkpath};
+use File::Spec;
+use Pod::Usage qw{pod2usage};
+
+# Usage
+# ------------------------------------------------------------------------------
+my $this = basename($0);
+
+# Options
+# ------------------------------------------------------------------------------
+my ($dest, $full, $help, $url);
+my $rc = GetOptions(
+ 'dest|d=s' => \$dest,
+ 'full|f' => \$full,
+ 'help' => \$help,
+ 'url|u=s' => \$url,
+);
+if (!$rc) {
+ pod2usage({'-verbose' => 1});
+}
+if ($help) {
+ pod2usage({'-exitval' => 0, '-verbose' => 1});
+}
+if (!$url) {
+ pod2usage(
+ {'-message' => 'The --url=URL option is compulsory', '-verbose' => 1},
+ );
+}
+$dest ||= cwd();
+
+# Arguments
+# ------------------------------------------------------------------------------
+if (@ARGV) {
+ die 'Cannot read: ', $ARGV[0], ', abort' unless -f $ARGV[0] and -r $ARGV[0];
+}
+
+# Get configuration settings
+# ------------------------------------------------------------------------------
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+# Expand URL keyword
+$url = Fcm::Util::tidy_url(Fcm::Keyword::expand($url));
+
+# ------------------------------------------------------------------------------
+
+MAIN: {
+ my $date = localtime;
+ print $this, ': started on ', $date, "\n";
+
+ my %dirs;
+
+ # Read input (file) for a list directories and update conditions
+ while (<>) {
+ chomp;
+
+ # Ignore empty and comment lines
+ next if /^\s*(?:#|$)/;
+
+ # Each line must contain a relative path, and optionally a list of
+ # space delimited conditions
+ my @words = split /\s+/;
+ my $dir = shift @words;
+
+ # Check that the conditions are valid
+ my @conditions;
+ for my $word (@words) {
+ if ($word =~ /^([<>]=?|[!=]=)(.+)$/i) {
+ # Condition must be a conditional operator followed by a revision
+ my ($operator, $rev) = ($1, $2);
+ $rev = (Fcm::Keyword::expand($url, $rev))[1];
+ push @conditions, $operator . $rev;
+
+ } else {
+ print STDERR 'Warning: ignore unknown syntax for update condition: ',
+ $word, "\n";
+ }
+ }
+
+ # Add directory and its conditions to a hash
+ if ($dir =~ s#/\*$##) { # Directory finishes with wildcard
+
+ # Run "svn ls" in recursive mode
+ my $dirurl = join ('/', ($url, $dir));
+ my @files = &run_command ([qw/svn ls -R/, $dirurl], METHOD => 'qx');
+
+ # Find directories containing regular files
+ while (my $file = shift @files) {
+ # Skip directories
+ next if $file =~ m#/$#;
+
+ # Get "dirname" of regular file and add to hash
+ my $subdir = join ('/', ($dir, dirname ($file)));
+ $dirs{$subdir} = \@conditions;
+ }
+
+ } else {
+ $dirs{$dir} = \@conditions;
+ }
+
+ }
+
+ # Update each directory, if required
+ for my $dir (sort keys %dirs) {
+ # Use "svn log" to determine the revisions that need to be updated
+ my %allversions;
+ {
+ my $command = 'svn log -q ' . join ('/', ($url, $dir));
+ my @log = &run_command (
+ [qw/svn log -q/, join ('/', ($url, $dir))], METHOD => 'qx',
+ );
+ @log = grep /^r\d+/, @log;
+
+ # Assign a sequential "version" number to each sub-directory
+ my $version = scalar @log;
+ for (@log) {
+ m/^r(\d+)/;
+ $allversions{$1} = 'v' . $version--;
+ }
+ }
+ my %versions = %allversions;
+
+ # Extract only revisions matching the conditions
+ if (@{ $dirs{$dir} }) {
+ my @conditions = @{ $dirs{$dir} };
+
+ for my $condition (@conditions) {
+ for my $rev (keys %versions) {
+ delete $versions{$rev} unless eval ($rev . $condition);
+ }
+ }
+ }
+
+ # Destination directory
+ my $dirpath = File::Spec->catfile ($dest, $dir);
+
+ if (-d $dirpath) {
+ if ($full or not keys %versions) {
+ # Remove destination directory top, in full mode
+ # or if there are no matching revisions
+ &run_command ([qw/rm -rf/, $dirpath], PRINT => 1);
+
+ } else {
+ # Delete excluded revisions if they exist, in incremental mode
+ if (opendir DIR, $dirpath) {
+ while (my $rev = readdir 'DIR') {
+ next unless $rev =~ /^\d+$/;
+
+ if (not grep {$_ eq $rev} keys %versions) {
+ my @command = (qw/rm -rf/, File::Spec->catfile ($dirpath, $rev));
+ &run_command (\@command, PRINT => 1);
+
+ # Remove "version" symlink
+ my $verlink = File::Spec->catfile ($dirpath, $allversions{$rev});
+ unlink $verlink if -l $verlink;
+ }
+ }
+ closedir DIR;
+ }
+ }
+ }
+
+ # Create container directory of destination if it does not already exist
+ if (keys %versions and not -d $dirpath) {
+ print '-> mkdir -p ', $dirpath, "\n";
+ my $rc = mkpath $dirpath;
+ die 'mkdir -p ', $dirpath, ' failed' unless $rc;
+ }
+
+ # Update each version directory that needs updating
+ for my $rev (keys %versions) {
+ my $revpath = File::Spec->catfile ($dest, $dir, $rev);
+
+ # Create version directory if it does not exist
+ if (not -e $revpath) {
+ # Use "svn export" to create the version directory
+ my @command = (
+ qw/svn export -q -r/,
+ $rev,
+ join ('/', ($url, $dir)),
+ $revpath,
+ );
+
+ &run_command (\@command, PRINT => 1);
+ }
+
+ # Create "version" symlink if necessary
+ my $verlink = File::Spec->catfile ($dest, $dir, $versions{$rev});
+ symlink $rev, $verlink unless -l $verlink;
+ }
+
+ # Symbolic link to the "latest" version directory
+ my $headlink = File::Spec->catfile ($dest, $dir, 'latest');
+ my $headrev = 0;
+ for my $rev (keys %versions) {
+ $headrev = $rev if $rev > $headrev;
+ }
+
+ if (-l $headlink) {
+ # Remove old symbolic link if there is no revision to update or if it
+ # does not point to the correct version directory
+ my $org = readlink $headlink;
+ unlink $headlink if (! $headrev or $org ne $headrev);
+ }
+
+ # (Re-)create the "latest" symbolic link, if necessary
+ symlink $headrev, $headlink if ($headrev and not -l $headlink);
+ }
+
+ $date = localtime;
+ print $this, ': finished normally on ', $date, "\n";
+}
+
+__END__
+
+=head1 NAME
+
+fcm_update_version_dir.pl
+
+=head1 SYNOPSIS
+
+ fcm_update_version_dir.pl [OPTIONS] [CFGFILE]
+
+=head1 DESCRIPTION
+
+Update the version directories for a list of relative paths in the source
+repository URL.
+
+=head1 OPTIONS
+
+=over 4
+
+=item --dest=DEST, -d DEST
+
+Specify a destination for the extraction. If not specified, the command extracts
+to the current working directory.
+
+=item --help, -h
+
+Print help and exit.
+
+=item --full, -f
+
+Specify the full mode. If not specified, the command runs in incremental mode.
+
+=item --url=URL, -u URL
+
+Specify the source repository URL. No default.
+
+=back
+
+=head1 ARGUMENTS
+
+A configuration file may be given to this command, or it will attempt to read
+from the standard input. Each line in the configuration must contain a relative
+path that resides under the given source repository URL. (Empty lines and lines
+beginning with a "#" are ignored.) Optionally, each relative path may be
+followed by a list of space separated "conditions". Each condition is a
+conditional operator (>, >=, <, <=, == or !=) followed by a revision number or
+the keyword HEAD. The command uses the revision log to determine the revisions
+at which the relative path has been updated in the source repository URL. If
+these revisions also satisfy the "conditions" set by the user, they will be
+considered in the extraction. In full mode, everything is re-extracted. In
+incremental mode, the version directories are only updated if they do not
+already exist.
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/etc/fcm.cfg.eg
===================================================================
--- NEMO/trunk/ext/FCM/etc/fcm.cfg.eg (revision 9596)
+++ NEMO/trunk/ext/FCM/etc/fcm.cfg.eg (revision 9596)
@@ -0,0 +1,266 @@
+# ------------------------------------------------------------------------------
+# FCM central configuration file
+# ------------------------------------------------------------------------------
+
+# ------------------------------------------------------------------------------
+# Standard repository locations
+# ------------------------------------------------------------------------------
+
+# 3dVOM repository
+set::url::3dvom svn://fcm9/3dVOM_svn/3dVOM
+
+# AAPP repository
+set::url::aapp svn://fcm7/AAPP_svn/AAPP
+
+# AMV repository
+set::url::amv svn://fcm7/AMV_svn/AMV
+
+# ANCIL repository
+set::url::ancil svn://fcm8/ANCIL_svn/ANCIL
+
+# ATSR repository
+set::url::atsr svn://fcm7/ATSR_svn/ATSR
+
+# BLASIUS repository
+set::url::blasius svn://fcm2/BLASIUS_svn/BLASIUS
+
+# CICE repository
+set::url::cice svn://fcm3/CICE_svn/CICE
+
+# CMA repository
+set::url::cma svn://fcm9/CMA_svn/CMA
+
+# CVC repository
+set::url::cvc_admin svn://fcm6/CVC_svn/Admin
+set::url::bufr svn://fcm6/CVC_svn/BUFR
+set::url::bullseye svn://fcm6/CVC_svn/Bullseye
+set::url::cat svn://fcm6/CVC_svn/CAT
+set::url::deicing svn://fcm6/CVC_svn/Deicing
+set::url::ea svn://fcm6/CVC_svn/EA
+set::url::ensemble svn://fcm6/CVC_svn/Ensemble
+set::url::gales svn://fcm6/CVC_svn/Gales
+set::url::ifv svn://fcm6/CVC_svn/IFV
+set::url::mogreps svn://fcm6/CVC_svn/MOGREPS
+set::url::openroad svn://fcm6/CVC_svn/OpenRoad
+set::url::powertable svn://fcm6/CVC_svn/PowerTable
+set::url::qnh svn://fcm6/CVC_svn/QNH
+set::url::tafs svn://fcm6/CVC_svn/TAFS
+set::url::warnings svn://fcm6/CVC_svn/WARNINGS
+
+# DA repository
+set::url::da svn://fcm5/DA_svn/DA
+
+# ENS repository
+set::url::ens svn://fcm9/ENS_svn/ENS
+
+# ERSEM repository
+set::url::ersem svn://fcm3/ERSEM_svn/ERSEM
+set::url::ersem_pml svn://fcm3/ERSEM_svn/ERSEM_PML
+
+# FCM repository
+set::url::fcm svn://fcm1/FCM_svn/FCM
+set::url::fcm_admin svn://fcm1/FCM_svn/Admin
+
+
+# FLUME repository
+set::url::flume_metadata svn://fcm2/FLUME_svn/metadata
+set::url::flume_framework svn://fcm2/FLUME_svn/framework
+set::url::flume_models svn://fcm2/FLUME_svn/models
+set::url::flume_jobs svn://fcm2/FLUME_svn/jobs
+
+# FORMOST repository
+set::url::formost_local svn://fcm9/FORMOST_svn/FORMOST_LOCAL
+set::url::formost_remote svn://fcm9/FORMOST_svn/FORMOST_REMOTE
+
+# GEN repository
+set::url::gen svn://fcm1/GEN_svn/GEN
+
+# GS repository
+set::url::gs svn://fcm9/GS_svn/GS
+
+# HadGOA repository
+set::url::hadgoa svn://fcm9/HadGOA_svn/HadGOA
+
+# HadISD repository
+set::url::hadisd_gen svn://fcm9/HadISD_svn/general
+set::url::hadisd_homog svn://fcm9/HadISD_svn/homogenisation
+set::url::hadisd_qc svn://fcm9/HadISD_svn/quality_control
+
+# IRIS repository
+set::url::iris svn://fcm9/IRIS_svn/IRIS
+
+# LEM repository
+set::url::lem svn://fcm2/LEM_svn/LEM
+
+# LINK repository
+set::url::link svn://fcm1/LINK_svn/LINK
+
+# MASS_MIG repository
+set::url::mass_mig svn://fcm9/MASS_MIG_svn/MASS_MIG
+
+# MOOSE repository
+set::url::moose svn://fcm9/MOOSE_svn/MOOSE
+
+# MOSIG repository
+set::url::mosig svn://fcm9/MOSIG_svn/MOSIG
+
+# MUMTI repository
+set::url::mumti svn://fcm1/MUMTI_svn/Project
+
+# NEMO repository
+set::url::nemosys svn://fcm3/NEMO_svn/NEMOSYS
+set::url::nemovar svn://fcm3/NEMO_svn/NEMOVAR
+set::url::nemo svn://fcm3/NEMO_svn/NEMO
+set::url::ioipsl svn://fcm3/NEMO_svn/IOIPSL
+set::url::ocnasm svn://fcm3/NEMO_svn/OCNASM
+set::url::nemoukmo svn://fcm3/NEMO_svn/UKMO
+
+# NWPSAF repository
+
+set::url::meto_1dvar svn://fcm7/NWPSAF_svn/MetOffice_1DVar
+set::url::ssmis_1dvar svn://fcm7/NWPSAF_svn/ssmis_1DVar
+set::url::ssmis_pp svn://fcm7/NWPSAF_svn/ssmis_PP
+
+# NWPWEB repository
+set::url::www_nwp svn://fcm1/NWPWEB_svn/www_nwp
+
+# obsmon repository
+set::url::obsmon_dc svn://fcm4/obsmon_svn/DC
+set::url::obsmon_rtm svn://fcm4/obsmon_svn/RTM
+
+# ODB repository
+set::url::odb svn://fcm4/ODB_svn/ODB
+
+# OCN repository
+set::url::polcoms svn://fcm3/OCN_svn/POLCOMS
+
+# OPFC repository
+set::url::opfc svn://fcm9/OPFC_svn/OPFC
+
+# OPS repository
+set::url::ops svn://fcm4/OPS_svn/OPS
+set::url::ops_admin svn://fcm4/OPS_svn/Admin
+set::url::ops_data svn://fcm4/OPS_svn/Data
+set::url::ops_external svn://fcm4/OPS_svn/External
+
+# OSTIA repository
+set::url::ostia svn://fcm3/OSTIA_svn/OSTIA
+
+# PF repository
+set::url::pf svn://fcm5/PF_svn/PF
+
+# PostProc repository
+set::url::pp svn://fcm9/PostProc_svn/PostProc
+set::url::ppancil svn://fcm9/PostProc_svn/PostProcAncil
+set::url::ppvssps svn://fcm9/PostProc_svn/VerificationSSPS
+
+# PRISM repository
+set::url::oasis3 svn://fcm2/PRISM_svn/OASIS3
+set::url::oasis4 svn://fcm2/PRISM_svn/OASIS4
+set::url::prism_ukmo svn://fcm2/PRISM_svn/PRISM_UKMO
+
+# radarnet repository
+set::url::radarnet4 svn://fcm9/radarnet_svn/radarnet4
+
+# RADSAT repository
+set::url::polar svn://fcm7/RADSAT_svn/POLAR
+set::url::radsat svn://fcm7/RADSAT_svn/RADSAT
+
+# ROPP repository
+set::url::ropp_doc svn://fcm7/ROPP_svn/ropp_doc
+set::url::ropp_src svn://fcm7/ROPP_svn/ropp_src
+set::url::ropp_test svn://fcm7/ROPP_svn/ropp_test
+set::url::ropp_web svn://fcm7/ROPP_svn/ropp_web
+
+# RTTOV repository
+set::url::rttov svn://fcm7/RTTOV_svn/RTTOV
+set::url::rttov8 svn://fcm7/RTTOV_svn/RTTOV8
+set::url::rttov9 svn://fcm7/RTTOV_svn/RTTOV9
+
+# SAUtils repository
+set::url::autoscat_global svn://fcm7/SAUtils_svn/AUTOSCAT_Global
+set::url::autoscat_nae svn://fcm7/SAUtils_svn/AUTOSCAT_NAE
+set::url::climetop svn://fcm7/SAUtils_svn/CLIMETOP
+set::url::dataflow svn://fcm7/SAUtils_svn/DataFlow
+set::url::gpsiwv_mon svn://fcm7/SAUtils_svn/GPSIWV_Mon
+set::url::gpswv_nrt svn://fcm7/SAUtils_svn/GPSWV_NRT
+set::url::gpsro_mon svn://fcm7/SAUtils_svn/GPSRO_Mon
+set::url::iasi_mon svn://fcm7/SAUtils_svn/IASI_Mon
+set::url::metstrike svn://fcm7/SAUtils_svn/METSTRIKE
+set::url::scatwind_mon svn://fcm7/SAUtils_svn/Scatwind_Mon
+
+# SBV repository
+set::url::sbv svn://fcm6/SBV_svn/SBV
+set::url::sbv_admin svn://fcm6/SBV_svn/Admin
+
+# SCS repository
+set::url::scs svn://fcm1/SCS_svn/SCS
+set::url::scs_admin svn://fcm1/SCS_svn/Admin
+set::url::tik svn://fcm1/SCS_svn/TIK
+set::url::tt svn://fcm1/SCS_svn/TT
+
+# SPS repository
+set::url::sps svn://fcm7/SPS_svn/SPS
+set::url::tigger svn://fcm7/SPS_svn/Tigger
+set::url::sps_archive svn://fcm7/SPS_svn/Archive
+
+# SURF repository
+set::url::surf svn://fcm8/SURF_svn/SURF
+
+# SWARV repository
+set::url::swarv svn://fcm9/SWARV_svn/SWARV
+
+# test repository
+set::url::test svn://fcm1/test_svn/OPS
+
+# tutorial repository
+set::url::tutorial svn://fcm1/tutorial_svn/tutorial
+
+# THORPEX repository
+set::url::thorpex svn://fcm9/ENS_svn/ENS
+
+# TRUI repository
+set::url::trui svn://fcm1/TRUI_svn/TRUI
+
+# UM repository
+set::url::um svn://fcm2/UM_svn/UM
+set::url::um_admin svn://fcm2/UM_svn/Admin
+set::url::gcom svn://fcm2/UM_svn/GCOM
+
+# UM tutorial repository
+set::url::um_tutorial svn://fcm2/UM_TUTORIAL_svn/UM
+
+# utils repository
+set::url::app_publications svn://fcm9/utils_svn/APP_publications
+set::url::asyncios svn://fcm9/utils_svn/asyncIOS
+set::url::avapps_coldsoak svn://fcm9/utils_svn/avapps_coldsoak
+set::url::avapps_verCB svn://fcm9/utils_svn/avapps_verCB
+set::url::crmtest svn://fcm9/utils_svn/cr_model_testing
+set::url::cr_valnote svn://fcm9/utils_svn/cr_validation_note
+set::url::fray_utils svn://fcm9/utils_svn/fray_utils
+set::url::hpss_tests svn://fcm9/utils_svn/HPSS_tests
+set::url::jules_benchmarking svn://fcm9/utils_svn/jules_benchmarking
+set::url::jules_standalone svn://fcm9/utils_svn/jules_standalone
+set::url::kid svn://fcm9/utils_svn/KiD
+set::url::numerical_methods svn://fcm9/utils_svn/numerical_methods
+set::url::wavefc svn://fcm9/utils_svn/wave_forecasting
+
+# VAR repository
+set::url::var svn://fcm5/VAR_svn/VAR
+set::url::var_admin svn://fcm5/VAR_svn/Admin
+set::url::var_data svn://fcm5/VAR_svn/Data
+
+# VER repository
+set::url::ver svn://fcm6/VER_svn/VER
+set::url::ver_admin svn://fcm6/VER_svn/Admin
+set::url::ver_archive svn://fcm6/VER_svn/Archive
+
+# VMM repository
+set::url::vmm svn://fcm9/VMM_svn/VMM
+
+# WW3 repository
+set::url::ww3 svn://fcm3/WW3_svn/WW3
+set::url::ww3_config svn://fcm3/WW3_svn/WW3CONFIG
+set::url::ww3_utils svn://fcm3/WW3_svn/WW3UTILS
+
+# EOF
Index: NEMO/trunk/ext/FCM/etc/fcm_gui.desktop
===================================================================
--- NEMO/trunk/ext/FCM/etc/fcm_gui.desktop (revision 9596)
+++ NEMO/trunk/ext/FCM/etc/fcm_gui.desktop (revision 9596)
@@ -0,0 +1,13 @@
+[Desktop Entry]
+Comment=
+Exec=fcm gui %f
+Hidden=false
+Icon=wizard
+MimeType=inode/directory
+Name=FCM GUI
+Path=
+Terminal=0
+TerminalOptions=
+Type=Application
+X-KDE-SubstituteUID=false
+X-KDE-Username=
Index: NEMO/trunk/ext/FCM/lib/Fcm/Base.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/Base.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/Base.pm (revision 9596)
@@ -0,0 +1,112 @@
+# ------------------------------------------------------------------------------
+# NAME
+# Fcm::Base
+#
+# DESCRIPTION
+# This is base class for all FCM OO packages.
+#
+# COPYRIGHT
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Base;
+
+# Standard pragma
+use strict;
+use warnings;
+
+use Fcm::Config;
+
+my @scalar_properties = (
+ 'config', # instance of Fcm::Config, configuration setting
+);
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $obj = Fcm::Base->new;
+#
+# DESCRIPTION
+# This method constructs a new instance of the Fcm::Base class.
+# ------------------------------------------------------------------------------
+
+sub new {
+ my $this = shift;
+ my %args = @_;
+ my $class = ref $this || $this;
+
+ my $self = {};
+ for (@scalar_properties) {
+ $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
+ }
+
+ bless $self, $class;
+ return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @scalar_properties.
+# ------------------------------------------------------------------------------
+
+for my $name (@scalar_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my $self = shift;
+
+ # Argument specified, set property to specified argument
+ if (@_) {
+ $self->{$name} = $_[0];
+ }
+
+ # Default value for property
+ if (not defined $self->{$name}) {
+ if ($name eq 'config') {
+ # Configuration setting of the main program
+ $self->{$name} = Fcm::Config->instance();
+ }
+ }
+
+ return $self->{$name};
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $self->setting (@args); # $self->config->setting
+# $value = $self->verbose (@args); # $self->config->verbose
+# ------------------------------------------------------------------------------
+
+for my $name (qw/setting verbose/) {
+ no strict 'refs';
+
+ *$name = sub {
+ my $self = shift;
+ return $self->config->$name (@_);
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $self->cfglabel (@args);
+#
+# DESCRIPTION
+# This is an alias to $self->config->setting ('CFG_LABEL', @args);
+# ------------------------------------------------------------------------------
+
+sub cfglabel {
+ my $self = shift;
+ return $self->setting ('CFG_LABEL', @_);
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: NEMO/trunk/ext/FCM/lib/Fcm/Build.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/Build.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/Build.pm (revision 9596)
@@ -0,0 +1,1606 @@
+# ------------------------------------------------------------------------------
+# NAME
+# Fcm::Build
+#
+# DESCRIPTION
+# This is the top level class for the FCM build system.
+#
+# COPYRIGHT
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+package Fcm::Build;
+use base qw(Fcm::ConfigSystem);
+
+use Carp qw{croak} ;
+use Cwd qw{cwd} ;
+use Fcm::BuildSrc ;
+use Fcm::BuildTask ;
+use Fcm::Config ;
+use Fcm::Dest ;
+use Fcm::CfgLine ;
+use Fcm::Timer qw{timestamp_command} ;
+use Fcm::Util qw{expand_tilde run_command touch_file w_report};
+use File::Basename qw{dirname} ;
+use File::Spec ;
+use List::Util qw{first} ;
+use Text::ParseWords qw{shellwords} ;
+
+# List of scalar property methods for this class
+my @scalar_properties = (
+ 'name', # name of this build
+ 'target', # targets of this build
+);
+
+# List of hash property methods for this class
+my @hash_properties = (
+ 'srcpkg', # source packages of this build
+ 'dummysrcpkg', # dummy for handling package inheritance with file extension
+);
+
+# List of compare_setting_X methods
+my @compare_setting_methods = (
+ 'compare_setting_bld_blockdata', # program executable blockdata dependency
+ 'compare_setting_bld_dep', # custom dependency setting
+ 'compare_setting_bld_dep_excl', # exclude dependency setting
+ 'compare_setting_bld_dep_n', # no dependency check
+ 'compare_setting_bld_dep_pp', # custom PP dependency setting
+ 'compare_setting_bld_dep_exe', # program executable extra dependency
+ 'compare_setting_bld_exe_name', # program executable rename
+ 'compare_setting_bld_pp', # PP flags
+ 'compare_setting_infile_ext', # input file extension
+ 'compare_setting_outfile_ext', # output file extension
+ 'compare_setting_tool', # build tool settings
+);
+
+my $DELIMITER_LIST = $Fcm::Config::DELIMITER_LIST;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $obj = Fcm::Build->new;
+#
+# DESCRIPTION
+# This method constructs a new instance of the Fcm::Build class.
+# ------------------------------------------------------------------------------
+
+sub new {
+ my $this = shift;
+ my %args = @_;
+ my $class = ref $this || $this;
+
+ my $self = Fcm::ConfigSystem->new (%args);
+
+ $self->{$_} = undef for (@scalar_properties);
+
+ $self->{$_} = {} for (@hash_properties);
+
+ bless $self, $class;
+
+ # List of sub-methods for parse_cfg
+ push @{ $self->cfg_methods }, (qw/target source tool dep misc/);
+
+ # Optional prefix in configuration declaration
+ $self->cfg_prefix ($self->setting (qw/CFG_LABEL BDECLARE/));
+
+ # System type
+ $self->type ('bld');
+
+ return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @scalar_properties.
+# ------------------------------------------------------------------------------
+
+for my $name (@scalar_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my $self = shift;
+
+ # Argument specified, set property to specified argument
+ if (@_) {
+ $self->{$name} = $_[0];
+ }
+
+ # Default value for property
+ if (not defined $self->{$name}) {
+ if ($name eq 'target') {
+ # Reference to an array
+ $self->{$name} = [];
+
+ } elsif ($name eq 'name') {
+ # Empty string
+ $self->{$name} = '';
+ }
+ }
+
+ return $self->{$name};
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# %hash = %{ $obj->X () };
+# $obj->X (\%hash);
+#
+# $value = $obj->X ($index);
+# $obj->X ($index, $value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @hash_properties.
+#
+# If no argument is set, this method returns a hash containing a list of
+# objects. If an argument is set and it is a reference to a hash, the objects
+# are replaced by the the specified hash.
+#
+# If a scalar argument is specified, this method returns a reference to an
+# object, if the indexed object exists or undef if the indexed object does
+# not exist. If a second argument is set, the $index element of the hash will
+# be set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+for my $name (@hash_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my ($self, $arg1, $arg2) = @_;
+
+ # Ensure property is defined as a reference to a hash
+ $self->{$name} = {} if not defined ($self->{$name});
+
+ # Argument 1 can be a reference to a hash or a scalar index
+ my ($index, %hash);
+
+ if (defined $arg1) {
+ if (ref ($arg1) eq 'HASH') {
+ %hash = %$arg1;
+
+ } else {
+ $index = $arg1;
+ }
+ }
+
+ if (defined $index) {
+ # A scalar index is defined, set and/or return the value of an element
+ $self->{$name}{$index} = $arg2 if defined $arg2;
+
+ return (
+ exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
+ );
+
+ } else {
+ # A scalar index is not defined, set and/or return the hash
+ $self->{$name} = \%hash if defined $arg1;
+ return $self->{$name};
+ }
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# ($rc, $new_lines) = $self->X ($old_lines);
+#
+# DESCRIPTION
+# This method compares current settings with those in the cache, where X is
+# one of @compare_setting_methods.
+#
+# If setting has changed:
+# * For bld_blockdata, bld_dep_ext and bld_exe_name, it sets the re-generate
+# make-rule flag to true.
+# * For bld_dep_excl, in a standalone build, the method will remove the
+# dependency cache files for affected sub-packages. It returns an error if
+# the current build inherits from previous builds.
+# * For bld_pp, it updates the PP setting for affected sub-packages.
+# * For infile_ext, in a standalone build, the method will remove all the
+# sub-package cache files and trigger a re-build by removing most
+# sub-directories created by the previous build. It returns an error if the
+# current build inherits from previous builds.
+# * For outfile_ext, in a standalone build, the method will remove all the
+# sub-package dependency cache files. It returns an error if the current
+# build inherits from previous builds.
+# * For tool, it updates the "flags" files for any changed tools.
+# ------------------------------------------------------------------------------
+
+for my $name (@compare_setting_methods) {
+ no strict 'refs';
+
+ *$name = sub {
+ my ($self, $old_lines) = @_;
+
+ (my $prefix = uc ($name)) =~ s/^COMPARE_SETTING_//;
+
+ my ($changed, $new_lines) =
+ $self->compare_setting_in_config ($prefix, $old_lines);
+
+ my $rc = scalar (keys %$changed);
+
+ if ($rc and $old_lines) {
+ $self->srcpkg ('')->is_updated (1);
+
+ if ($name =~ /^compare_setting_bld_dep(?:_excl|_n|_pp)?$/) {
+ # Mark affected packages as being updated
+ for my $key (keys %$changed) {
+ for my $pkg (values %{ $self->srcpkg }) {
+ next unless $pkg->is_in_package ($key);
+ $pkg->is_updated (1);
+ }
+ }
+
+ } elsif ($name eq 'compare_setting_bld_pp') {
+ # Mark affected packages as being updated
+ for my $key (keys %$changed) {
+ for my $pkg (values %{ $self->srcpkg }) {
+ next unless $pkg->is_in_package ($key);
+ next unless $self->srcpkg ($key)->is_type_any (
+ keys %{ $self->setting ('BLD_TYPE_DEP_PP') }
+ ); # Is a type requiring pre-processing
+
+ $pkg->is_updated (1);
+ }
+ }
+
+ } elsif ($name eq 'compare_setting_infile_ext') {
+ # Re-set input file type if necessary
+ for my $key (keys %$changed) {
+ for my $pkg (values %{ $self->srcpkg }) {
+ next unless $pkg->src and $pkg->ext and $key eq $pkg->ext;
+
+ $pkg->type (undef);
+ }
+ }
+
+ # Mark affected packages as being updated
+ for my $pkg (values %{ $self->srcpkg }) {
+ $pkg->is_updated (1);
+ }
+
+ } elsif ($name eq 'compare_setting_outfile_ext') {
+ # Mark affected packages as being updated
+ for my $pkg (values %{ $self->srcpkg }) {
+ $pkg->is_updated (1);
+ }
+
+ } elsif ($name eq 'compare_setting_tool') {
+ # Update the "flags" files for changed tools
+ for my $name (sort keys %$changed) {
+ my ($tool, @names) = split /__/, $name;
+ my $pkg = join ('__', @names);
+ my @srcpkgs = $self->srcpkg ($pkg)
+ ? ($self->srcpkg ($pkg))
+ : @{ $self->dummysrcpkg ($pkg)->children };
+
+ for my $srcpkg (@srcpkgs) {
+ my $file = File::Spec->catfile (
+ $self->dest->flagsdir, $srcpkg->flagsbase ($tool)
+ );
+ &touch_file ($file) or croak $file, ': cannot update, abort';
+
+ print $file, ': updated', "\n" if $self->verbose > 2;
+ }
+ }
+ }
+ }
+
+ return ($rc, $new_lines);
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# ($rc, $new_lines) = $self->compare_setting_dependency ($old_lines, $flag);
+#
+# DESCRIPTION
+# This method uses the previous settings to determine the dependencies of
+# current source files.
+# ------------------------------------------------------------------------------
+
+sub compare_setting_dependency {
+ my ($self, $old_lines, $flag) = @_;
+
+ my $prefix = $flag ? 'DEP_PP' : 'DEP';
+ my $method = $flag ? 'ppdep' : 'dep';
+
+ my $rc = 0;
+ my $new_lines = [];
+
+ # Separate old lines
+ my %old;
+ if ($old_lines) {
+ for my $line (@$old_lines) {
+ next unless $line->label_starts_with ($prefix);
+ $old{$line->label_from_field (1)} = $line;
+ }
+ }
+
+ # Go through each source to see if the cache is up to date
+ my $count = 0;
+ my %mtime;
+ for my $srcpkg (values %{ $self->srcpkg }) {
+ next unless $srcpkg->cursrc and $srcpkg->type;
+
+ my $key = $srcpkg->pkgname;
+ my $out_of_date = $srcpkg->is_updated;
+
+ # Check modification time of cache and source file if not out of date
+ if (exists $old{$key}) {
+ if (not $out_of_date) {
+ $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9]
+ if not exists ($mtime{$old{$key}->src});
+
+ $out_of_date = 1 if $mtime{$old{$key}->src} < $srcpkg->curmtime;
+ }
+ }
+ else {
+ $out_of_date = 1;
+ }
+
+ if ($out_of_date) {
+ # Re-scan dependency
+ $srcpkg->is_updated(1);
+ my ($source_is_read, $dep_hash_ref) = $srcpkg->get_dep($flag);
+ if ($source_is_read) {
+ $count++;
+ }
+ $srcpkg->$method($dep_hash_ref);
+ $rc = 1;
+ }
+ else {
+ # Use cached dependency
+ my ($progname, %hash) = split (
+ /$Fcm::Config::DELIMITER_PATTERN/, $old{$key}->value
+ );
+ $srcpkg->progname ($progname) if $progname and not $flag;
+ $srcpkg->$method (\%hash);
+ }
+
+ # New lines values: progname[::dependency-name::type][...]
+ my @value = ((defined $srcpkg->progname ? $srcpkg->progname : ''));
+ for my $name (sort keys %{ $srcpkg->$method }) {
+ push @value, $name, $srcpkg->$method ($name);
+ }
+
+ push @$new_lines, Fcm::CfgLine->new (
+ LABEL => $prefix . $Fcm::Config::DELIMITER . $key,
+ VALUE => join ($Fcm::Config::DELIMITER, @value),
+ );
+ }
+
+ print 'No. of file', ($count > 1 ? 's' : ''), ' scanned for',
+ ($flag ? ' PP': ''), ' dependency: ', $count, "\n"
+ if $self->verbose and $count;
+
+ return ($rc, $new_lines);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# ($rc, $new_lines) = $self->compare_setting_srcpkg ($old_lines);
+#
+# DESCRIPTION
+# This method uses the previous settings to determine the type of current
+# source files.
+# ------------------------------------------------------------------------------
+
+sub compare_setting_srcpkg {
+ my ($self, $old_lines) = @_;
+
+ my $prefix = 'SRCPKG';
+
+ # Get relevant items from old lines, stripping out $prefix
+ my %old;
+ if ($old_lines) {
+ for my $line (@$old_lines) {
+ next unless $line->label_starts_with ($prefix);
+ $old{$line->label_from_field (1)} = $line;
+ }
+ }
+
+ # Check for change, use previous setting if exist
+ my $out_of_date = 0;
+ my %mtime;
+ for my $key (keys %{ $self->srcpkg }) {
+ if (exists $old{$key}) {
+ next unless $self->srcpkg ($key)->cursrc;
+
+ my $type = defined $self->setting ('BLD_TYPE', $key)
+ ? $self->setting ('BLD_TYPE', $key) : $old{$key}->value;
+
+ $self->srcpkg ($key)->type ($type);
+
+ if ($type ne $old{$key}->value) {
+ $self->srcpkg ($key)->is_updated (1);
+ $out_of_date = 1;
+ }
+
+ if (not $self->srcpkg ($key)->is_updated) {
+ $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9]
+ if not exists ($mtime{$old{$key}->src});
+
+ $self->srcpkg ($key)->is_updated (1)
+ if $mtime{$old{$key}->src} < $self->srcpkg ($key)->curmtime;
+ }
+
+ } else {
+ $self->srcpkg ($key)->is_updated (1);
+ $out_of_date = 1;
+ }
+ }
+
+ # Check for deleted keys
+ for my $key (keys %old) {
+ next if $self->srcpkg ($key);
+
+ $out_of_date = 1;
+ }
+
+ # Return reference to an array of new lines
+ my $new_lines = [];
+ for my $key (keys %{ $self->srcpkg }) {
+ push @$new_lines, Fcm::CfgLine->new (
+ LABEL => $prefix . $Fcm::Config::DELIMITER . $key,
+ VALUE => $self->srcpkg ($key)->type,
+ );
+ }
+
+ return ($out_of_date, $new_lines);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# ($rc, $new_lines) = $self->compare_setting_target ($old_lines);
+#
+# DESCRIPTION
+# This method compare the previous target settings with current ones.
+# ------------------------------------------------------------------------------
+
+sub compare_setting_target {
+ my ($self, $old_lines) = @_;
+
+ my $prefix = 'TARGET';
+ my $old;
+ if ($old_lines) {
+ for my $line (@$old_lines) {
+ next unless $line->label_starts_with ($prefix);
+ $old = $line->value;
+ last;
+ }
+ }
+
+ my $new = join (' ', sort @{ $self->target });
+
+ return (
+ (defined ($old) ? $old ne $new : 1),
+ [Fcm::CfgLine->new (LABEL => $prefix, VALUE => $new)],
+ );
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_fortran_interface_generator ();
+#
+# DESCRIPTION
+# This method invokes the Fortran interface generator for all Fortran free
+# format source files. It returns true on success.
+# ------------------------------------------------------------------------------
+
+sub invoke_fortran_interface_generator {
+ my $self = shift;
+
+ my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/);
+
+ # Set up build task to generate interface files for all selected Fortran 9x
+ # sources
+ my %task = ();
+ SRC_FILE:
+ for my $srcfile (values %{ $self->srcpkg }) {
+ if (!defined($srcfile->interfacebase())) {
+ next SRC_FILE;
+ }
+ my $target = $srcfile->interfacebase . $pdoneext;
+
+ $task{$target} = Fcm::BuildTask->new (
+ TARGET => $target,
+ TARGETPATH => $self->dest->donepath,
+ SRCFILE => $srcfile,
+ DEPENDENCY => [$srcfile->flagsbase ('GENINTERFACE')],
+ ACTIONTYPE => 'GENINTERFACE',
+ );
+
+ # Set up build tasks for each source file/package flags file for interface
+ # generator tool
+ for my $i (1 .. @{ $srcfile->pkgnames }) {
+ my $target = $srcfile->flagsbase ('GENINTERFACE', -$i);
+ my $depend = $i < @{ $srcfile->pkgnames }
+ ? $srcfile->flagsbase ('GENINTERFACE', -$i - 1)
+ : undef;
+
+ $task{$target} = Fcm::BuildTask->new (
+ TARGET => $target,
+ TARGETPATH => $self->dest->flagspath,
+ DEPENDENCY => [defined ($depend) ? $depend : ()],
+ ACTIONTYPE => 'UPDATE',
+ ) if not exists $task{$target};
+ }
+ }
+
+ # Set up build task to update the flags file for interface generator tool
+ $task{$self->srcpkg ('')->flagsbase ('GENINTERFACE')} = Fcm::BuildTask->new (
+ TARGET => $self->srcpkg ('')->flagsbase ('GENINTERFACE'),
+ TARGETPATH => $self->dest->flagspath,
+ ACTIONTYPE => 'UPDATE',
+ );
+
+ my $count = 0;
+
+ # Performs task
+ for my $task (values %task) {
+ next unless $task->actiontype eq 'GENINTERFACE';
+
+ my $rc = $task->action (TASKLIST => \%task);
+ $count++ if $rc;
+ }
+
+ print 'No. of generated Fortran interface', ($count > 1 ? 's' : ''), ': ',
+ $count, "\n"
+ if $self->verbose and $count;
+
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_make (%args);
+#
+# DESCRIPTION
+# This method invokes the make stage of the build system. It returns true on
+# success.
+#
+# ARGUMENTS
+# ARCHIVE - If set to "true", invoke the "archive" mode. Most build files and
+# directories created by this build will be archived using the
+# "tar" command. If not set, the default is not to invoke the
+# "archive" mode.
+# JOBS - Specify number of jobs that can be handled by "make". If set, the
+# value must be a natural integer. If not set, the default value is
+# 1 (i.e. run "make" in serial mode).
+# TARGETS - Specify targets to be built. If set, these targets will be built
+# instead of the ones specified in the build configuration file.
+# ------------------------------------------------------------------------------
+
+sub invoke_make {
+ my ($self, %args) = @_;
+ $args{TARGETS} ||= ['all'];
+ $args{JOBS} ||= 1;
+ my @command = (
+ $self->setting(qw/TOOL MAKE/),
+ shellwords($self->setting(qw/TOOL MAKEFLAGS/)),
+ # -f Makefile
+ ($self->setting(qw/TOOL MAKE_FILE/), $self->dest()->bldmakefile()),
+ # -j N
+ ($args{JOBS} ? ($self->setting(qw/TOOL MAKE_JOB/), $args{JOBS}) : ()),
+ # -s
+ ($self->verbose() >= 3 ? $self->setting(qw/TOOL MAKE_SILENT/) : ()),
+ @{$args{TARGETS}}
+ );
+ my $old_cwd = $self->_chdir($self->dest()->rootdir());
+ run_command(
+ \@command, ERROR => 'warn', RC => \my($code), TIME => $self->verbose() >= 3,
+ );
+ $self->_chdir($old_cwd);
+
+ my $rc = !$code;
+ if ($rc && $args{ARCHIVE}) {
+ $rc = $self->dest()->archive();
+ }
+ $rc &&= $self->dest()->create_bldrunenvsh();
+ while (my ($key, $source) = each(%{$self->srcpkg()})) {
+ $rc &&= defined($source->write_lib_dep_excl());
+ }
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_pre_process ();
+#
+# DESCRIPTION
+# This method invokes the pre-process stage of the build system. It
+# returns true on success.
+# ------------------------------------------------------------------------------
+
+sub invoke_pre_process {
+ my $self = shift;
+
+ # Check whether pre-processing is necessary
+ my $invoke = 0;
+ for (values %{ $self->srcpkg }) {
+ next unless $_->get_setting ('BLD_PP');
+ $invoke = 1;
+ last;
+ }
+ return 1 unless $invoke;
+
+ # Scan header dependency
+ my $rc = $self->compare_setting (
+ METHOD_LIST => ['compare_setting_dependency'],
+ METHOD_ARGS => ['BLD_TYPE_DEP_PP'],
+ CACHEBASE => $self->setting ('CACHE_DEP_PP'),
+ );
+
+ return $rc if not $rc;
+
+ my %task = ();
+ my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/);
+
+ # Set up tasks for each source file
+ for my $srcfile (values %{ $self->srcpkg }) {
+ if ($srcfile->is_type_all (qw/CPP INCLUDE/)) {
+ # Set up a copy build task for each include file
+ $task{$srcfile->base} = Fcm::BuildTask->new (
+ TARGET => $srcfile->base,
+ TARGETPATH => $self->dest->incpath,
+ SRCFILE => $srcfile,
+ DEPENDENCY => [keys %{ $srcfile->ppdep }],
+ ACTIONTYPE => 'COPY',
+ );
+
+ } elsif ($srcfile->lang ('TOOL_SRC_PP')) {
+ next unless $srcfile->get_setting ('BLD_PP');
+
+ # Set up a PP build task for each source file
+ my $target = $srcfile->base . $pdoneext;
+
+ # Issue warning for duplicated tasks
+ if (exists $task{$target}) {
+ w_report 'WARNING: ', $target, ': unable to create task for: ',
+ $srcfile->src, ': task already exists for: ',
+ $task{$target}->srcfile->src;
+ next;
+ }
+
+ $task{$target} = Fcm::BuildTask->new (
+ TARGET => $target,
+ TARGETPATH => $self->dest->donepath,
+ SRCFILE => $srcfile,
+ DEPENDENCY => [$srcfile->flagsbase ('PPKEYS'), keys %{ $srcfile->ppdep }],
+ ACTIONTYPE => 'PP',
+ );
+
+ # Set up update ppkeys/flags build tasks for each source file/package
+ my $ppkeys = $self->setting (
+ 'TOOL_SRC_PP', $srcfile->lang ('TOOL_SRC_PP'), 'PPKEYS'
+ );
+
+ for my $i (1 .. @{ $srcfile->pkgnames }) {
+ my $target = $srcfile->flagsbase ($ppkeys, -$i);
+ my $depend = $i < @{ $srcfile->pkgnames }
+ ? $srcfile->flagsbase ($ppkeys, -$i - 1)
+ : undef;
+
+ $task{$target} = Fcm::BuildTask->new (
+ TARGET => $target,
+ TARGETPATH => $self->dest->flagspath,
+ DEPENDENCY => [defined ($depend) ? $depend : ()],
+ ACTIONTYPE => 'UPDATE',
+ ) if not exists $task{$target};
+ }
+ }
+ }
+
+ # Set up update global ppkeys build tasks
+ for my $lang (keys %{ $self->setting ('TOOL_SRC_PP') }) {
+ my $target = $self->srcpkg ('')->flagsbase (
+ $self->setting ('TOOL_SRC_PP', $lang, 'PPKEYS')
+ );
+
+ $task{$target} = Fcm::BuildTask->new (
+ TARGET => $target,
+ TARGETPATH => $self->dest->flagspath,
+ ACTIONTYPE => 'UPDATE',
+ );
+ }
+
+ # Build all PP tasks
+ my $count = 0;
+ for my $task (values %task) {
+ next unless $task->actiontype eq 'PP';
+
+ my $rc = $task->action (TASKLIST => \%task);
+ $task->srcfile->is_updated ($rc);
+ $count++ if $rc;
+ }
+
+ print 'No. of pre-processed file', ($count > 1 ? 's' : ''), ': ', $count, "\n"
+ if $self->verbose and $count;
+
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_scan_dependency ();
+#
+# DESCRIPTION
+# This method invokes the scan dependency stage of the build system. It
+# returns true on success.
+# ------------------------------------------------------------------------------
+
+sub invoke_scan_dependency {
+ my $self = shift;
+
+ # Scan/retrieve dependency
+ # ----------------------------------------------------------------------------
+ my $rc = $self->compare_setting (
+ METHOD_LIST => ['compare_setting_dependency'],
+ CACHEBASE => $self->setting ('CACHE_DEP'),
+ );
+
+ # Check whether make file is out of date
+ # ----------------------------------------------------------------------------
+ my $out_of_date = not -r $self->dest->bldmakefile;
+
+ if ($rc and not $out_of_date) {
+ for (qw/CACHE CACHE_DEP/) {
+ my $cache_mtime = (stat (File::Spec->catfile (
+ $self->dest->cachedir, $self->setting ($_),
+ )))[9];
+ my $mfile_mtime = (stat ($self->dest->bldmakefile))[9];
+
+ next if not defined $cache_mtime;
+ next if $cache_mtime < $mfile_mtime;
+ $out_of_date = 1;
+ last;
+ }
+ }
+
+ if ($rc and not $out_of_date) {
+ for (values %{ $self->srcpkg }) {
+ next unless $_->is_updated;
+ $out_of_date = 1;
+ last;
+ }
+ }
+
+ if ($rc and $out_of_date) {
+ # Write Makefile
+ # --------------------------------------------------------------------------
+ # Register non-word package name
+ my $unusual = 0;
+ for my $key (sort keys %{ $self->srcpkg }) {
+ next if $self->srcpkg ($key)->src;
+ next if $key =~ /^\w*$/;
+
+ $self->setting (
+ ['FCM_PCK_OBJECTS', $key], 'FCM_PCK_OBJECTS' . $unusual++,
+ );
+ }
+
+ # Write different parts in the Makefile
+ my $makefile = '# Automatic Makefile' . "\n\n";
+ $makefile .= 'FCM_BLD_NAME = ' . $self->name . "\n" if $self->name;
+ $makefile .= 'FCM_BLD_CFG = ' . $self->cfg->actual_src . "\n";
+ $makefile .= 'export FCM_VERBOSE ?= ' . $self->verbose . "\n\n";
+ $makefile .= $self->dest->write_rules;
+ $makefile .= $self->_write_makefile_perl5lib;
+ $makefile .= $self->_write_makefile_tool;
+ $makefile .= $self->_write_makefile_vpath;
+ $makefile .= $self->_write_makefile_target;
+
+ # Write rules for each source package
+ # Ensure that container packages come before files - this allows $(OBJECTS)
+ # and its dependent variables to expand correctly
+ my @srcpkg = sort {
+ if ($self->srcpkg ($a)->libbase and $self->srcpkg ($b)->libbase) {
+ $b cmp $a;
+
+ } elsif ($self->srcpkg ($a)->libbase) {
+ -1;
+
+ } elsif ($self->srcpkg ($b)->libbase) {
+ 1;
+
+ } else {
+ $a cmp $b;
+ }
+ } keys %{ $self->srcpkg };
+
+ for (@srcpkg) {
+ $makefile .= $self->srcpkg ($_)->write_rules if $self->srcpkg ($_)->rules;
+ }
+ $makefile .= '# EOF' . "\n";
+
+ # Update Makefile
+ open OUT, '>', $self->dest->bldmakefile
+ or croak $self->dest->bldmakefile, ': cannot open (', $!, '), abort';
+ print OUT $makefile;
+ close OUT
+ or croak $self->dest->bldmakefile, ': cannot close (', $!, '), abort';
+
+ print $self->dest->bldmakefile, ': updated', "\n" if $self->verbose;
+
+ # Check for duplicated targets
+ # --------------------------------------------------------------------------
+ # Get list of types that cannot have duplicated targets
+ my @no_duplicated_target_types = split (
+ /$DELIMITER_LIST/,
+ $self->setting ('BLD_TYPE_NO_DUPLICATED_TARGET'),
+ );
+
+ my %targets;
+ for my $name (sort keys %{ $self->srcpkg }) {
+ next unless $self->srcpkg ($name)->rules;
+
+ for my $key (sort keys %{ $self->srcpkg ($name)->rules }) {
+ if (exists $targets{$key}) {
+ # Duplicated target: warning for most file types
+ my $status = 'WARNING';
+
+ # Duplicated target: error for the following file types
+ if (@no_duplicated_target_types and
+ $self-srcpkg ($name)->is_type_any (@no_duplicated_target_types) and
+ $targets{$key}->is_type_any (@no_duplicated_target_types)) {
+ $status = 'ERROR';
+ $rc = 0;
+ }
+
+ # Report the warning/error
+ w_report $status, ': ', $key, ': duplicated targets for building:';
+ w_report ' ', $targets{$key}->src;
+ w_report ' ', $self->srcpkg ($name)->src;
+
+ } else {
+ $targets{$key} = $self->srcpkg ($name);
+ }
+ }
+ }
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_setup_build ();
+#
+# DESCRIPTION
+# This method invokes the setup_build stage of the build system. It returns
+# true on success.
+# ------------------------------------------------------------------------------
+
+sub invoke_setup_build {
+ my $self = shift;
+
+ my $rc = 1;
+
+ # Extract archived sub-directories if necessary
+ $rc = $self->dest->dearchive if $rc;
+
+ # Compare cache
+ $rc = $self->compare_setting (METHOD_LIST => [
+ 'compare_setting_target', # targets
+ 'compare_setting_srcpkg', # source package type
+ @compare_setting_methods,
+ ]) if $rc;
+
+ # Set up runtime dependency scan patterns
+ my %dep_pattern = %{ $self->setting ('BLD_DEP_PATTERN') };
+ for my $key (keys %dep_pattern) {
+ my $pattern = $dep_pattern{$key};
+
+ while ($pattern =~ /##([\w:]+)##/g) {
+ my $match = $1;
+ my $val = $self->setting (split (/$Fcm::Config::DELIMITER/, $match));
+
+ last unless defined $val;
+ $val =~ s/\./\\./;
+
+ $pattern =~ s/##$match##/$val/;
+ }
+
+ $self->setting (['BLD_DEP_PATTERN', $key], $pattern)
+ unless $pattern eq $dep_pattern{$key};
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->invoke_system (%args);
+#
+# DESCRIPTION
+# This method invokes the build system. It returns true on success. See also
+# the header for invoke_make for further information on arguments.
+#
+# ARGUMENTS
+# STAGE - If set, it should be an integer number or a recognised keyword or
+# abbreviation. If set, the build is performed up to the named stage.
+# If not set, the default is to perform all stages of the build.
+# Allowed values are:
+# 1, setup or s
+# 2, pre_process or pp
+# 3, generate_dependency or gd
+# 4, generate_interface or gi
+# 5, all, a, make or m
+# ------------------------------------------------------------------------------
+
+sub invoke_system {
+ my $self = shift;
+ my %args = @_;
+
+ # Parse arguments
+ # ----------------------------------------------------------------------------
+ # Default: run all 5 stages
+ my $stage = (exists $args{STAGE} and $args{STAGE}) ? $args{STAGE} : 5;
+
+ # Resolve named stages
+ if ($stage !~ /^\d$/) {
+ my %stagenames = (
+ 'S(?:ETUP)?' => 1,
+ 'P(?:RE)?_?P(?:ROCESS)?' => 2,
+ 'G(?:ENERATE)?_?D(?:ENPENDENCY)?' => 3,
+ 'G(?:ENERATE)?_?I(?:NTERFACE)?' => 4,
+ '(?:A(?:LL)|M(?:AKE)?)' => 5,
+ );
+
+ # Does it match a recognised stage?
+ for my $name (keys %stagenames) {
+ next unless $stage =~ /$name/i;
+
+ $stage = $stagenames{$name};
+ last;
+ }
+
+ # Specified stage name not recognised, default to 5
+ if ($stage !~ /^\d$/) {
+ w_report 'WARNING: ', $stage, ': invalid build stage, default to 5.';
+ $stage = 5;
+ }
+ }
+
+ # Run the method associated with each stage
+ # ----------------------------------------------------------------------------
+ my $rc = 1;
+
+ my @stages = (
+ ['Setup build' , 'invoke_setup_build'],
+ ['Pre-process' , 'invoke_pre_process'],
+ ['Scan dependency' , 'invoke_scan_dependency'],
+ ['Generate Fortran interface', 'invoke_fortran_interface_generator'],
+ ['Make' , 'invoke_make'],
+ );
+
+ for my $i (1 .. 5) {
+ last if (not $rc) or $i > $stage;
+
+ my ($name, $method) = @{ $stages[$i - 1] };
+ $rc = $self->invoke_stage ($name, $method, %args) if $rc and $stage >= $i;
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_dep (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses the dependency settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_dep {
+ my ($self, $cfg_lines) = @_;
+
+ my $rc = 1;
+
+ # EXCL_DEP, EXE_DEP and BLOCKDATA declarations
+ # ----------------------------------------------------------------------------
+ for my $name (qw/BLD_BLOCKDATA BLD_DEP BLD_DEP_EXCL BLD_DEP_EXE/) {
+ for my $line (grep {$_->slabel_starts_with_cfg ($name)} @$cfg_lines) {
+ # Separate label into a list, delimited by double-colon, remove 1st field
+ my @flds = $line->slabel_fields;
+ shift @flds;
+
+ if ($name =~ /^(?:BLD_DEP|BLD_DEP_EXCL|BLD_DEP_PP)$/) {
+ # BLD_DEP_*: label fields may contain sub-package
+ my $pk = @flds ? join ('__', @flds) : '';
+
+ # Check whether sub-package is valid
+ if ($pk and not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) {
+ $line->error ($line->label . ': invalid sub-package in declaration.');
+ $rc = 0;
+ next;
+ }
+
+ # Setting is stored in an array reference
+ $self->setting ([$name, $pk], [])
+ if not defined $self->setting ($name, $pk);
+
+ # Add current declaration to the array if necessary
+ my $list = $self->setting ($name, $pk);
+ my $value = $name eq 'BLD_DEP_EXCL' ? uc ($line->value) : $line->value;
+ push @$list, $value if not grep {$_ eq $value} @$list;
+
+ } else {
+ # EXE_DEP and BLOCKDATA: label field may be an executable target
+ my $target = @flds ? $flds[0] : '';
+
+ # The value contains a list of objects and/or sub-package names
+ my @deps = split /\s+/, $line->value;
+
+ if (not @deps) {
+ if ($name eq 'BLD_BLOCKDATA') {
+ # The objects containing a BLOCKDATA program unit must be declared
+ $line->error ($line->label . ': value not set.');
+ $rc = 0;
+ next;
+
+ } else {
+ # If $value is a null string, target(s) depends on all objects
+ push @deps, '';
+ }
+ }
+
+ for my $dep (@deps) {
+ $dep =~ s/$Fcm::Config::DELIMITER_PATTERN/__/g;
+ }
+
+ $self->setting ([$name, $target], join (' ', sort @deps));
+ }
+
+ $line->parsed (1);
+ }
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_dest (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses the build destination settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_dest {
+ my ($self, $cfg_lines) = @_;
+
+ my $rc = $self->SUPER::parse_cfg_dest ($cfg_lines);
+
+ # Set up search paths
+ for my $name (@Fcm::Dest::paths) {
+ (my $label = uc ($name)) =~ s/PATH//;
+
+ $self->setting (['PATH', $label], $self->dest->$name);
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_misc (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses misc build settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_misc {
+ my ($self, $cfg_lines_ref) = @_;
+ my $rc = 1;
+ my %item_of = (
+ BLD_DEP_N => [\&_parse_cfg_misc_dep_n , 1 ], # boolean
+ BLD_EXE_NAME => [\&_parse_cfg_misc_exe_name ],
+ BLD_LIB => [\&_parse_cfg_misc_dep_n ],
+ BLD_PP => [\&_parse_cfg_misc_dep_n , 1 ], # boolean
+ BLD_TYPE => [\&_parse_cfg_misc_dep_n ],
+ INFILE_EXT => [\&_parse_cfg_misc_file_ext, 0, 1], # uc($value)
+ OUTFILE_EXT => [\&_parse_cfg_misc_file_ext, 1, 0], # uc($ns)
+ );
+ while (my ($key, $item) = each(%item_of)) {
+ my ($handler, @extra_arguments) = @{$item};
+ for my $line (@{$cfg_lines_ref}) {
+ if ($line->slabel_starts_with_cfg($key)) {
+ if ($handler->($self, $key, $line, @extra_arguments)) {
+ $line->parsed(1);
+ }
+ else {
+ $rc = 0;
+ }
+ }
+ }
+ }
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# parse_cfg_misc: handler of BLD_EXE_NAME or similar.
+sub _parse_cfg_misc_exe_name {
+ my ($self, $key, $line) = @_;
+ my ($prefix, $name, @fields) = $line->slabel_fields();
+ if (!$name || @fields) {
+ $line->error(sprintf('%s: expects a single label name field.', $key));
+ return 0;
+ }
+ $self->setting([$key, $name], $line->value());
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# parse_cfg_misc: handler of BLD_DEP_N or similar.
+sub _parse_cfg_misc_dep_n {
+ my ($self, $key, $line, $value_is_boolean) = @_;
+ my ($prefix, @fields) = $line->slabel_fields();
+ my $ns = @fields ? join(q{__}, @fields) : q{};
+ if ($ns && !$self->srcpkg($ns) && !$self->dummysrcpkg($ns)) {
+ $line->error($line->label() . ': invalid sub-package in declaration.');
+ return 0;
+ }
+ my @srcpkgs
+ = $self->dummysrcpkg($ns) ? @{$self->dummysrcpkg($ns)->children()}
+ : $self->srcpkg($ns)
+ ;
+ my $value = $value_is_boolean ? $line->bvalue() : $line->value();
+ for my $srcpkg (@srcpkgs) {
+ $self->setting([$key, $srcpkg->pkgname()], $value);
+ }
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# parse_cfg_misc: handler of INFILE_EXT/OUTFILE_EXT or similar.
+sub _parse_cfg_misc_file_ext {
+ my ($self, $key, $line, $ns_in_uc, $value_in_uc) = @_;
+ my ($prefix, $ns) = $line->slabel_fields();
+ my $value = $value_in_uc ? uc($line->value()) : $line->value();
+ $self->setting([$key, ($ns_in_uc ? uc($ns) : $ns)], $value);
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_source (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses the source package settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_source {
+ my ($self, $cfg_lines) = @_;
+
+ my $rc = 1;
+ my %src = ();
+
+ # Automatic source directory search?
+ # ----------------------------------------------------------------------------
+ my $search = 1;
+
+ for my $line (grep {$_->slabel_starts_with_cfg ('SEARCH_SRC')} @$cfg_lines) {
+ $search = $line->bvalue;
+ $line->parsed (1);
+ }
+
+ # Search src/ sub-directory if necessary
+ %src = %{ $self->dest->get_source_files } if $search;
+
+ # SRC declarations
+ # ----------------------------------------------------------------------------
+ for my $line (grep {$_->slabel_starts_with_cfg ('FILE')} @$cfg_lines) {
+ # Expand ~ notation and path relative to srcdir of destination
+ my $value = $line->value;
+ $value = File::Spec->rel2abs (&expand_tilde ($value), $self->dest->srcdir);
+
+ if (not -r $value) {
+ $line->error ($value . ': source does not exist or is not readable.');
+ next;
+ }
+
+ # Package name
+ my @names = $line->slabel_fields;
+ shift @names;
+
+ # If package name not set, determine using the path if possible
+ if (not @names) {
+ my $package = $self->dest->get_pkgname_of_path ($value);
+ @names = @$package if defined $package;
+ }
+
+ if (not @names) {
+ $line->error ($self->cfglabel ('FILE') .
+ ': package not specified/cannot be determined.');
+ next;
+ }
+
+ $src{join ('__', @names)} = $value;
+
+ $line->parsed (1);
+ }
+
+ # For directories, get non-recursive file listing, and add to %src
+ # ----------------------------------------------------------------------------
+ for my $key (keys %src) {
+ next unless -d $src{$key};
+
+ opendir DIR, $src{$key} or die $src{$key}, ': cannot read directory';
+ while (my $base = readdir 'DIR') {
+ next if $base =~ /^\./;
+
+ my $file = File::Spec->catfile ($src{$key}, $base);
+ next unless -f $file and -r $file;
+
+ my $name = join ('__', ($key, $base));
+ $src{$name} = $file unless exists $src{$name};
+ }
+ closedir DIR;
+
+ delete $src{$key};
+ }
+
+ # Set up source packages
+ # ----------------------------------------------------------------------------
+ my %pkg = ();
+ for my $name (keys %src) {
+ $pkg{$name} = Fcm::BuildSrc->new (PKGNAME => $name, SRC => $src{$name});
+ }
+
+ # INHERIT::SRC declarations
+ # ----------------------------------------------------------------------------
+ my %can_inherit = ();
+ for my $line (
+ grep {$_->slabel_starts_with_cfg(qw/INHERIT FILE/)} @{$cfg_lines}
+ ) {
+ my ($key1, $key2, @ns) = $line->slabel_fields();
+ $can_inherit{join('__', @ns)} = $line->bvalue();
+ $line->parsed(1);
+ }
+
+ # Inherit packages, if it is OK to do so
+ for my $inherited_build (reverse(@{$self->inherit()})) {
+ SRCPKG:
+ while (my ($key, $srcpkg) = each(%{$inherited_build->srcpkg()})) {
+ if (exists($pkg{$key}) || !$srcpkg->src()) {
+ next SRCPKG;
+ }
+ my $known_key = first {exists($can_inherit{$_})} @{$srcpkg->pkgnames()};
+ if (defined($known_key) && !$can_inherit{$known_key}) {
+ next SRCPKG;
+ }
+ $pkg{$key} = $srcpkg;
+ }
+ }
+
+ # Get list of intermediate "packages"
+ # ----------------------------------------------------------------------------
+ for my $name (keys %pkg) {
+ # Name of current package
+ my @names = split /__/, $name;
+
+ my $cur = $name;
+
+ while ($cur) {
+ # Name of parent package
+ pop @names;
+ my $parent = @names ? join ('__', @names) : '';
+
+ # If parent package does not exist, create it
+ $pkg{$parent} = Fcm::BuildSrc->new (PKGNAME => $parent)
+ unless exists $pkg{$parent};
+
+ # Current package is a child of the parent package
+ push @{ $pkg{$parent}->children }, $pkg{$cur}
+ unless grep {$_->pkgname eq $cur} @{ $pkg{$parent}->children };
+
+ # Go up a package
+ $cur = $parent;
+ }
+ }
+
+ $self->srcpkg (\%pkg);
+
+ # Dummy: e.g. "foo/bar/baz.egg" belongs to the "foo/bar/baz" dummy.
+ # ----------------------------------------------------------------------------
+ for my $name (keys %pkg) {
+ (my $dname = $name) =~ s/\.\w+$//;
+ next if $dname eq $name;
+ next if $self->srcpkg ($dname);
+
+ $self->dummysrcpkg ($dname, Fcm::BuildSrc->new (PKGNAME => $dname))
+ unless $self->dummysrcpkg ($dname);
+ push @{ $self->dummysrcpkg ($dname)->children }, $pkg{$name};
+ }
+
+ # Make sure a package is defined
+ # ----------------------------------------------------------------------------
+ if (not %{$self->srcpkg}) {
+ w_report 'ERROR: ', $self->cfg->actual_src, ': no source file to build.';
+ $rc = 0;
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_target (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses the target settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_target {
+ my ($self, $cfg_lines) = @_;
+
+ # NAME declaraions
+ # ----------------------------------------------------------------------------
+ for my $line (grep {$_->slabel_starts_with_cfg ('NAME')} @$cfg_lines) {
+ $self->name ($line->value);
+ $line->parsed (1);
+ }
+
+ # TARGET declarations
+ # ----------------------------------------------------------------------------
+ for my $line (grep {$_->slabel_starts_with_cfg ('TARGET')} @$cfg_lines) {
+ # Value is a space delimited list
+ push @{ $self->target }, split (/\s+/, $line->value);
+ $line->parsed (1);
+ }
+
+ # INHERIT::TARGET declarations
+ # ----------------------------------------------------------------------------
+ # By default, do not inherit target
+ my $inherit_flag = 0;
+
+ for (grep {$_->slabel_starts_with_cfg (qw/INHERIT TARGET/)} @$cfg_lines) {
+ $inherit_flag = $_->bvalue;
+ $_->parsed (1);
+ }
+
+ # Inherit targets from inherited build, if $inherit_flag is set to true
+ # ----------------------------------------------------------------------------
+ if ($inherit_flag) {
+ for my $use (reverse @{ $self->inherit }) {
+ unshift @{ $self->target }, @{ $use->target };
+ }
+ }
+
+ return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $self->parse_cfg_tool (\@cfg_lines);
+#
+# DESCRIPTION
+# This method parses the tool settings in the @cfg_lines.
+# ------------------------------------------------------------------------------
+
+sub parse_cfg_tool {
+ my ($self, $cfg_lines) = @_;
+
+ my $rc = 1;
+
+ my %tools = %{ $self->setting ('TOOL') };
+ my @package_tools = split(/$DELIMITER_LIST/, $self->setting('TOOL_PACKAGE'));
+
+ # TOOL declaration
+ # ----------------------------------------------------------------------------
+ for my $line (grep {$_->slabel_starts_with_cfg ('TOOL')} @$cfg_lines) {
+ # Separate label into a list, delimited by double-colon, remove TOOL
+ my @flds = $line->slabel_fields;
+ shift @flds;
+
+ # Check that there is a field after TOOL
+ if (not @flds) {
+ $line->error ('TOOL: not followed by a valid label.');
+ $rc = 0;
+ next;
+ }
+
+ # The first field is the tool iteself, identified in uppercase
+ $flds[0] = uc ($flds[0]);
+
+ # Check that the tool is recognised
+ if (not exists $tools{$flds[0]}) {
+ $line->error ($flds[0] . ': not a valid TOOL.');
+ $rc = 0;
+ next;
+ }
+
+ # Check sub-package declaration
+ if (@flds > 1 and not grep {$_ eq $flds[0]} @package_tools) {
+ $line->error ($flds[0] . ': sub-package not accepted with this TOOL.');
+ $rc = 0;
+ next;
+ }
+
+ # Name of declared package
+ my $pk = join ('__', @flds[1 .. $#flds]);
+
+ # Check whether package exists
+ if (not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) {
+ $line->error ($line->label . ': invalid sub-package in declaration.');
+ $rc = 0;
+ next;
+ }
+
+ $self->setting (['TOOL', join ('__', @flds)], $line->value);
+ $line->parsed (1);
+ }
+
+ return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $self->_write_makefile_perl5lib ();
+#
+# DESCRIPTION
+# This method returns a makefile $string for defining $PERL5LIB.
+# ------------------------------------------------------------------------------
+
+sub _write_makefile_perl5lib {
+ my $self = shift;
+
+ my $classpath = File::Spec->catfile (split (/::/, ref ($self))) . '.pm';
+
+ my $libdir = dirname (dirname ($INC{$classpath}));
+ my @libpath = split (/:/, (exists $ENV{PERL5LIB} ? $ENV{PERL5LIB} : ''));
+
+ my $string = ((grep {$_ eq $libdir} @libpath)
+ ? ''
+ : 'export PERL5LIB := ' . $libdir .
+ (exists $ENV{PERL5LIB} ? ':$(PERL5LIB)' : '') . "\n\n");
+
+ return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $self->_write_makefile_target ();
+#
+# DESCRIPTION
+# This method returns a makefile $string for defining the default targets.
+# ------------------------------------------------------------------------------
+
+sub _write_makefile_target {
+ my $self = shift;
+
+ # Targets of the build
+ # ----------------------------------------------------------------------------
+ my @targets = @{ $self->target };
+ if (not @targets) {
+ # Build targets not specified by user, default to building all main programs
+ my @programs = ();
+
+ # Get all main programs from all packages
+ for my $pkg (values %{ $self->srcpkg }) {
+ push @programs, $pkg->exebase if $pkg->exebase;
+ }
+
+ @programs = sort (@programs);
+
+ if (@programs) {
+ # Build main programs, if there are any
+ @targets = @programs;
+
+ } else {
+ # No main program in source tree, build the default library
+ @targets = ($self->srcpkg ('')->libbase);
+ }
+ }
+
+ my $return = 'FCM_BLD_TARGETS = ' . join (' ', @targets) . "\n\n";
+
+ # Default targets
+ $return .= '.PHONY : all' . "\n\n";
+ $return .= 'all : $(FCM_BLD_TARGETS)' . "\n\n";
+
+ # Targets for copy dummy
+ $return .= sprintf("%s:\n\ttouch \$@\n\n", $self->setting(qw/BLD_CPDUMMY/));
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $self->_write_makefile_tool ();
+#
+# DESCRIPTION
+# This method returns a makefile $string for defining the build tools.
+# ------------------------------------------------------------------------------
+
+sub _write_makefile_tool {
+ my $self = shift;
+
+ # List of build tools
+ my $tool = $self->setting ('TOOL');
+
+ # List of tools local to FCM, (will not be exported)
+ my %localtool = map {($_, 1)} split ( # map into a hash table
+ /$DELIMITER_LIST/, $self->setting ('TOOL_LOCAL'),
+ );
+
+ # Export required tools
+ my $count = 0;
+ my $return = '';
+ for my $name (sort keys %$tool) {
+ # Ignore local tools
+ next if exists $localtool{(split (/__/, $name))[0]};
+
+ if ($name =~ /^\w+$/) {
+ # Tools with normal name, just export it as an environment variable
+ $return .= 'export ' . $name . ' = ' . $tool->{$name} . "\n";
+
+ } else {
+ # Tools with unusual characters, export using a label/value pair
+ $return .= 'export FCM_UNUSUAL_TOOL_LABEL' . $count . ' = ' . $name . "\n";
+ $return .= 'export FCM_UNUSUAL_TOOL_VALUE' . $count . ' = ' .
+ $tool->{$name} . "\n";
+ $count++;
+ }
+ }
+
+ $return .= "\n";
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $self->_write_makefile_vpath ();
+#
+# DESCRIPTION
+# This method returns a makefile $string for defining vpath directives.
+# ------------------------------------------------------------------------------
+
+sub _write_makefile_vpath {
+ my $self = shift();
+ my $FMT = 'vpath %%%s $(FCM_%sPATH)';
+ my %SETTING_OF = %{$self->setting('BLD_VPATH')};
+ my %EXT_OF = %{$self->setting('OUTFILE_EXT')};
+ # Note: each setting can be either an empty string or a comma-separated list
+ # of output file extension keys.
+ join(
+ "\n",
+ (
+ map
+ {
+ my $key = $_;
+ my @types = split(qr{$DELIMITER_LIST}msx, $SETTING_OF{$key});
+ @types ? (map {sprintf($FMT, $EXT_OF{$_}, $key)} sort @types)
+ : sprintf($FMT, q{}, $key)
+ ;
+ }
+ sort keys(%SETTING_OF)
+ ),
+ ) . "\n\n";
+}
+
+# Wraps chdir. Returns the old working directory.
+sub _chdir {
+ my ($self, $path) = @_;
+ if ($self->verbose() >= 3) {
+ printf("cd %s\n", $path);
+ }
+ my $old_cwd = cwd();
+ chdir($path) || croak(sprintf("%s: cannot change directory ($!)\n", $path));
+ $old_cwd;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: NEMO/trunk/ext/FCM/lib/Fcm/Build/Fortran.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/Build/Fortran.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/Build/Fortran.pm (revision 9596)
@@ -0,0 +1,536 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+# ------------------------------------------------------------------------------
+package Fcm::Build::Fortran;
+
+use Text::Balanced qw{extract_bracketed extract_delimited};
+
+# Actions of this class
+my %ACTION_OF = (extract_interface => \&_extract_interface);
+
+# Regular expressions
+# Matches a variable attribute
+my $RE_ATTR = qr{
+ allocatable|dimension|external|intent|optional|parameter|pointer|save|target
+}imsx;
+# Matches a name
+my $RE_NAME = qr{[A-Za-z]\w*}imsx;
+# Matches a specification type
+my $RE_SPEC = qr{
+ character|complex|double\s*precision|integer|logical|real|type
+}imsx;
+# Matches the identifier of a program unit that does not have arguments
+my $RE_UNIT_BASE = qr{block\s*data|module|program}imsx;
+# Matches the identifier of a program unit that has arguments
+my $RE_UNIT_CALL = qr{function|subroutine}imsx;
+# Matches the identifier of any program unit
+my $RE_UNIT = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx;
+my %RE = (
+ # A comment line
+ COMMENT => qr{\A\s*(?:!|\z)}msx,
+ # A trailing comment, capture the expression before the comment
+ COMMENT_END => qr{\A([^'"]*?)\s*!.*\z}msx,
+ # A contination marker, capture the expression before the marker
+ CONT => qr{\A(.*)&\s*\z}msx,
+ # A contination marker at the beginning of a line, capture the marker and
+ # the expression after the marker
+ CONT_LEAD => qr{\A(\s*&)(.*)\z}msx,
+ # Capture a variable identifier, removing any type component expression
+ NAME_COMP => qr{\b($RE_NAME)(?:\s*\%\s*$RE_NAME)*\b}msx,
+ # Matches the first identifier in a line
+ NAME_LEAD => qr{\A\s*$RE_NAME\s*}msx,
+ # Captures a name identifier after a comma, and the expression after
+ NAME_LIST => qr{\A(?:.*?)\s*,\s*($RE_NAME)\b(.*)\z}msx,
+ # Captures the next quote character
+ QUOTE => qr{\A[^'"]*(['"])}msx,
+ # Matches an attribute declaration
+ TYPE_ATTR => qr{\A\s*($RE_ATTR)\b}msx,
+ # Matches a type declaration
+ TYPE_SPEC => qr{\A\s*($RE_SPEC)\b}msx,
+ # Captures the expression after one or more program unit attributes
+ UNIT_ATTR => qr{\A\s*(?:(?:elemental|recursive|pure)\s+)+(.*)\z}imsx,
+ # Captures the identifier and the symbol of a program unit with no arguments
+ UNIT_BASE => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\s*\z}imsx,
+ # Captures the identifier and the symbol of a program unit with arguments
+ UNIT_CALL => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx,
+ # Captures the end of a program unit, its identifier and its symbol
+ UNIT_END => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\s*\z}imsx,
+ # Captures the expression after a program unit type specification
+ UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx,
+);
+
+# Keywords in type declaration statements
+my %TYPE_DECL_KEYWORD_SET = map { ($_, 1) } qw{
+ allocatable
+ dimension
+ in
+ inout
+ intent
+ kind
+ len
+ optional
+ out
+ parameter
+ pointer
+ save
+ target
+};
+
+# Creates and returns an instance of this class.
+sub new {
+ my ($class) = @_;
+ bless(
+ sub {
+ my $key = shift();
+ if (!exists($ACTION_OF{$key})) {
+ return;
+ }
+ $ACTION_OF{$key}->(@_);
+ },
+ $class,
+ );
+}
+
+# Methods.
+for my $key (keys(%ACTION_OF)) {
+ no strict qw{refs};
+ *{$key} = sub { my $self = shift(); $self->($key, @_) };
+}
+
+# Extracts the calling interfaces of top level subroutines and functions from
+# the $handle for reading Fortran sources.
+sub _extract_interface {
+ my ($handle) = @_;
+ map { _present_line($_) } @{_reduce_to_interface(_load($handle))};
+}
+
+# Reads $handle for the next Fortran statement, handling continuations.
+sub _load {
+ my ($handle) = @_;
+ my $ctx = {signature_token_set_of => {}, statements => []};
+ my $state = {
+ in_contains => undef, # in a "contains" section of a program unit
+ in_interface => undef, # in an "interface" block
+ in_quote => undef, # in a multi-line quote
+ stack => [], # program unit stack
+ };
+ my $NEW_STATEMENT = sub {
+ { name => q{}, # statement name, e.g. function, integer, ...
+ lines => [], # original lines in the statement
+ line_number => 0, # line number (start) in the original source
+ symbol => q{}, # name of a program unit (signature, end)
+ type => q{}, # e.g. signature, use, type, attr, end
+ value => q{}, # the actual value of the statement
+ };
+ };
+ my $statement;
+LINE:
+ while (my $line = readline($handle)) {
+ if (!defined($statement)) {
+ $statement = $NEW_STATEMENT->();
+ }
+ my $value = $line;
+ chomp($value);
+ # Pre-processor directives and continuation
+ if (!$statement->{line_number} && index($value, '#') == 0) {
+ $statement->{line_number} = $.;
+ $statement->{name} = 'cpp';
+ }
+ if ($statement->{name} eq 'cpp') {
+ push(@{$statement->{lines}}, $line);
+ $statement->{value} .= $value;
+ if (rindex($value, '\\') != length($value) - 1) {
+ $statement = undef;
+ }
+ next LINE;
+ }
+ # Normal Fortran
+ if ($value =~ $RE{COMMENT}) {
+ next LINE;
+ }
+ if (!$statement->{line_number}) {
+ $statement->{line_number} = $.;
+ }
+ my ($cont_head, $cont_tail);
+ if ($statement->{line_number} != $.) { # is a continuation
+ ($cont_head, $cont_tail) = $value =~ $RE{CONT_LEAD};
+ if ($cont_head) {
+ $value = $cont_tail;
+ }
+ }
+ # Correctly handle ! and & in quotes
+ my ($head, $tail) = (q{}, $value);
+ if ($state->{in_quote} && index($value, $state->{in_quote}) >= 0) {
+ my $index = index($value, $state->{in_quote});
+ $head = substr($value, 0, $index + 1);
+ $tail
+ = length($value) > $index + 1
+ ? substr($value, $index + 2)
+ : q{};
+ $state->{in_quote} = undef;
+ }
+ if (!$state->{in_quote}) {
+ while ($tail) {
+ if (index($tail, q{!}) >= 0) {
+ if (!($tail =~ s/$RE{COMMENT_END}/$1/)) {
+ ($head, $tail, $state->{in_quote})
+ = _load_extract_quote($head, $tail);
+ }
+ }
+ else {
+ while (index($tail, q{'}) > 0
+ || index($tail, q{"}) > 0)
+ {
+ ($head, $tail, $state->{in_quote})
+ = _load_extract_quote($head, $tail);
+ }
+ $head .= $tail;
+ $tail = q{};
+ }
+ }
+ }
+ $cont_head ||= q{};
+ push(@{$statement->{lines}}, $cont_head . $head . $tail . "\n");
+ $statement->{value} .= $head . $tail;
+ # Process a statement only if it is marked with a continuation
+ if (!($statement->{value} =~ s/$RE{CONT}/$1/)) {
+ $statement->{value} =~ s{\s+\z}{}msx;
+ if (_process($statement, $ctx, $state)) {
+ push(@{$ctx->{statements}}, $statement);
+ }
+ $statement = undef;
+ }
+ }
+ return $ctx;
+}
+
+# Helper, removes a quoted string from $tail.
+sub _load_extract_quote {
+ my ($head, $tail) = @_;
+ my ($extracted, $remainder, $prefix)
+ = extract_delimited($tail, q{'"}, qr{[^'"]*}msx, q{});
+ if ($extracted) {
+ return ($head . $prefix . $extracted, $remainder);
+ }
+ else {
+ my ($quote) = $tail =~ $RE{QUOTE};
+ return ($head . $tail, q{}, $quote);
+ }
+}
+
+# Study statements and put attributes into array $statements
+sub _process {
+ my ($statement, $ctx, $state) = @_;
+ my $name;
+
+ # End Interface
+ if ($state->{in_interface}) {
+ if ($statement->{value} =~ qr{\A\s*end\s*interface\b}imsx) {
+ $state->{in_interface} = 0;
+ }
+ return;
+ }
+
+ # End Program Unit
+ if (@{$state->{stack}} && $statement->{value} =~ qr{\A\s*end\b}imsx) {
+ my ($end, $type, $symbol) = lc($statement->{value}) =~ $RE{UNIT_END};
+ if (!$end) {
+ return;
+ }
+ my ($top_type, $top_symbol) = @{$state->{stack}->[-1]};
+ if (!$type
+ || $top_type eq $type && (!$symbol || $top_symbol eq $symbol))
+ {
+ pop(@{$state->{stack}});
+ if ($state->{in_contains} && !@{$state->{stack}}) {
+ $state->{in_contains} = 0;
+ }
+ if (!$state->{in_contains}) {
+ $statement->{name} = $top_type;
+ $statement->{symbol} = $top_symbol;
+ $statement->{type} = 'end';
+ return $statement;
+ }
+ }
+ return;
+ }
+
+ # Interface/Contains
+ ($name) = $statement->{value} =~ qr{\A\s*(contains|interface)\b}imsx;
+ if ($name) {
+ $state->{'in_' . lc($name)} = 1;
+ return;
+ }
+
+ # Program Unit
+ my ($type, $symbol, @tokens) = _process_prog_unit($statement->{value});
+ if ($type) {
+ push(@{$state->{stack}}, [$type, $symbol]);
+ if ($state->{in_contains}) {
+ return;
+ }
+ $statement->{name} = lc($type);
+ $statement->{type} = 'signature';
+ $statement->{symbol} = lc($symbol);
+ $ctx->{signature_token_set_of}{$symbol}
+ = {map { (lc($_) => 1) } @tokens};
+ return $statement;
+ }
+ if ($state->{in_contains}) {
+ return;
+ }
+
+ # Use
+ if ($statement->{value} =~ qr{\A\s*(use)\b}imsx) {
+ $statement->{name} = 'use';
+ $statement->{type} = 'use';
+ return $statement;
+ }
+
+ # Type Declarations
+ ($name) = $statement->{value} =~ $RE{TYPE_SPEC};
+ if ($name) {
+ $name =~ s{\s}{}gmsx;
+ $statement->{name} = lc($name);
+ $statement->{type} = 'type';
+ return $statement;
+ }
+
+ # Attribute Statements
+ ($name) = $statement->{value} =~ $RE{TYPE_ATTR};
+ if ($name) {
+ $statement->{name} = $name;
+ $statement->{type} = 'attr';
+ return $statement;
+ }
+}
+
+# Parse a statement for program unit header. Returns a list containing the type,
+# the symbol and the signature tokens of the program unit.
+sub _process_prog_unit {
+ my ($string) = @_;
+ my ($type, $symbol, @args) = (q{}, q{});
+ # Is it a blockdata, module or program?
+ ($type, $symbol) = $string =~ $RE{UNIT_BASE};
+ if ($type) {
+ $type = lc($type);
+ $type =~ s{\s*}{}gmsx;
+ return ($type, $symbol);
+ }
+ # Remove the attribute and type declaration of a procedure
+ $string =~ s/$RE{UNIT_ATTR}/$1/;
+ my ($match) = $string =~ $RE{UNIT_SPEC};
+ if ($match) {
+ $string = $match;
+ extract_bracketed($string);
+ }
+ # Is it a function or subroutine?
+ ($type, $symbol) = lc($string) =~ $RE{UNIT_CALL};
+ if (!$type) {
+ return;
+ }
+ my $extracted = extract_bracketed($string, q{()}, qr{[^(]*}msx);
+
+ # Get signature tokens from SUBROUTINE/FUNCTION
+ if ($extracted) {
+ $extracted =~ s{\s}{}gmsx;
+ @args = split(q{,}, substr($extracted, 1, length($extracted) - 2));
+ if ($type eq 'function') {
+ my $result = extract_bracketed($string, q{()}, qr{[^(]*}msx);
+ if ($result) {
+ $result =~ s{\A\(\s*(.*?)\s*\)\z}{$1}msx; # remove braces
+ push(@args, $result);
+ }
+ else {
+ push(@args, $symbol);
+ }
+ }
+ }
+ return (lc($type), lc($symbol), map { lc($_) } @args);
+}
+
+# Reduces the list of statements to contain only the interface block.
+sub _reduce_to_interface {
+ my ($ctx) = @_;
+ my (%token_set, @interface_statements);
+STATEMENT:
+ for my $statement (reverse(@{$ctx->{statements}})) {
+ if ($statement->{type} eq 'end'
+ && grep { $_ eq $statement->{name} } qw{subroutine function})
+ {
+ push(@interface_statements, $statement);
+ %token_set
+ = %{$ctx->{signature_token_set_of}{$statement->{symbol}}};
+ next STATEMENT;
+ }
+ if ($statement->{type} eq 'signature'
+ && grep { $_ eq $statement->{name} } qw{subroutine function})
+ {
+ push(@interface_statements, $statement);
+ %token_set = ();
+ next STATEMENT;
+ }
+ if ($statement->{type} eq 'use') {
+ my ($head, $tail)
+ = split(qr{\s*:\s*}msx, lc($statement->{value}), 2);
+ if ($tail) {
+ my @imports = map { [split(qr{\s*=>\s*}msx, $_, 2)] }
+ split(qr{\s*,\s*}msx, $tail);
+ my @useful_imports
+ = grep { exists($token_set{$_->[0]}) } @imports;
+ if (!@useful_imports) {
+ next STATEMENT;
+ }
+ if (@imports != @useful_imports) {
+ my @token_strings
+ = map { $_->[0] . ($_->[1] ? ' => ' . $_->[1] : q{}) }
+ @useful_imports;
+ my ($last, @rest) = reverse(@token_strings);
+ my @token_lines
+ = (reverse(map { $_ . q{,&} } @rest), $last);
+ push(
+ @interface_statements,
+ { lines => [
+ sprintf("%s:&\n", $head),
+ (map { sprintf(" & %s\n", $_) } @token_lines),
+ ]
+ },
+ );
+ next STATEMENT;
+ }
+ }
+ push(@interface_statements, $statement);
+ next STATEMENT;
+ }
+ if ($statement->{type} eq 'attr') {
+ my ($spec, @tokens) = ($statement->{value} =~ /$RE{NAME_COMP}/g);
+ if (grep { exists($token_set{$_}) } @tokens) {
+ for my $token (@tokens) {
+ $token_set{$token} = 1;
+ }
+ push(@interface_statements, $statement);
+ next STATEMENT;
+ }
+ }
+ if ($statement->{type} eq 'type') {
+ my ($variable_string, $spec_string)
+ = reverse(split('::', lc($statement->{value}), 2));
+ if ($spec_string) {
+ $spec_string =~ s{$RE{NAME_LEAD}}{}msx;
+ }
+ else {
+ # The first expression in the statement is the type + attrib
+ $variable_string =~ s{$RE{NAME_LEAD}}{}msx;
+ $spec_string = extract_bracketed($variable_string, '()',
+ qr{[\s\*]*}msx);
+ }
+ # Useful tokens are those that comes after a comma
+ my $tail = q{,} . lc($variable_string);
+ my @tokens;
+ while ($tail) {
+ if ($tail =~ qr{\A\s*['"]}msx) {
+ extract_delimited($tail, q{'"}, qr{\A[^'"]*}msx, q{});
+ }
+ elsif ($tail =~ qr{\A\s*\(}msx) {
+ extract_bracketed($tail, '()', qr{\A[^(]*}msx);
+ }
+ else {
+ my $token;
+ ($token, $tail) = $tail =~ $RE{NAME_LIST};
+ if ($token && $token_set{$token}) {
+ @tokens = ($variable_string =~ /$RE{NAME_COMP}/g);
+ $tail = q{};
+ }
+ }
+ }
+ if (@tokens && $spec_string) {
+ my @spec_tokens = (lc($spec_string) =~ /$RE{NAME_COMP}/g);
+ push(
+ @tokens,
+ ( grep { !exists($TYPE_DECL_KEYWORD_SET{$_}) }
+ @spec_tokens
+ ),
+ );
+ }
+ if (grep { exists($token_set{$_}) } @tokens) {
+ for my $token (@tokens) {
+ $token_set{$token} = 1;
+ }
+ push(@interface_statements, $statement);
+ next STATEMENT;
+ }
+ }
+ }
+ if (!@interface_statements) {
+ return [];
+ }
+ [ {lines => ["interface\n"]},
+ reverse(@interface_statements),
+ {lines => ["end interface\n"]},
+ ];
+}
+
+# Processes and returns the line of the statement.
+sub _present_line {
+ my ($statement) = @_;
+ map {
+ s{\s+}{ }gmsx; # collapse multiple spaces
+ s{\s+\z}{\n}msx; # remove trailing spaces
+ $_;
+ } @{$statement->{lines}};
+}
+
+# ------------------------------------------------------------------------------
+1;
+__END__
+
+=head1 NAME
+
+Fcm::Build::Fortran
+
+=head1 SYNOPSIS
+
+ use Fcm::Build::Fortran;
+ my $fortran_util = Fcm::Build::Fortran->new();
+ open(my($handle), '<', $path_to_a_fortran_source_file);
+ print($fortran_util->extract_interface($handle)); # prints interface
+ close($handle);
+
+=head1 DESCRIPTION
+
+A class to analyse Fortran source. Currently, it has a single method to extract
+the calling interfaces of top level subroutines and functions in a Fortran
+source.
+
+=head1 METHODS
+
+=over 4
+
+=item $class->new()
+
+Creates and returns an instance of this class.
+
+=item $instance->extract_interface($handle)
+
+Extracts the calling interfaces of top level subroutines and functions in a
+Fortran source that can be read from $handle. Returns an interface block as a
+list of lines.
+
+=back
+
+=head1 ACKNOWLEDGEMENT
+
+This module is inspired by the logic developed by the European Centre
+for Medium-Range Weather Forecasts (ECMWF).
+
+=head1 COPYRIGHT
+
+(C) Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/BuildSrc.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/BuildSrc.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/BuildSrc.pm (revision 9596)
@@ -0,0 +1,1498 @@
+# ------------------------------------------------------------------------------
+# NAME
+# Fcm::BuildSrc
+#
+# DESCRIPTION
+# This is a class to group functionalities of source in a build.
+#
+# COPYRIGHT
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+package Fcm::BuildSrc;
+use base qw{Fcm::Base};
+
+use Carp qw{croak};
+use Cwd qw{cwd};
+use Fcm::Build::Fortran;
+use Fcm::CfgFile;
+use Fcm::CfgLine;
+use Fcm::Config;
+use Fcm::Timer qw{timestamp_command};
+use Fcm::Util qw{find_file_in_path run_command};
+use File::Basename qw{basename dirname};
+use File::Spec;
+
+# List of scalar property methods for this class
+my @scalar_properties = (
+ 'children', # list of children packages
+ 'is_updated', # is this source (or its associated settings) updated?
+ 'mtime', # modification time of src
+ 'ppmtime', # modification time of ppsrc
+ 'ppsrc', # full path of the pre-processed source
+ 'pkgname', # package name of the source
+ 'progname', # program unit name in the source
+ 'src', # full path of the source
+ 'type', # type of the source
+);
+
+# List of hash property methods for this class
+my @hash_properties = (
+ 'dep', # dependencies
+ 'ppdep', # pre-process dependencies
+ 'rules', # make rules
+);
+
+# Error message formats
+my %ERR_MESS_OF = (
+ CHDIR => '%s: cannot change directory (%s), abort',
+ OPEN => '%s: cannot open (%s), abort',
+ CLOSE_PIPE => '%s: failed (%d), abort',
+);
+
+# Event message formats and levels
+my %EVENT_SETTING_OF = (
+ CHDIR => ['%s: change directory' , 2],
+ F_INTERFACE_NONE => ['%s: Fortran interface generation is off', 3],
+ GET_DEPENDENCY => ['%s: %d line(s), %d auto dependency(ies)', 3],
+);
+
+my %RE_OF = (
+ F_PREFIX => qr{
+ (?:
+ (?:ELEMENTAL|PURE(?:\s+RECURSIVE)?|RECURSIVE(?:\s+PURE)?)
+ \s+
+ )?
+ }imsx,
+ F_SPEC => qr{
+ (?:
+ (?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|LOGICAL|REAL|TYPE)
+ (?: \s* \( .+ \) | \s* \* \d+ \s*)??
+ \s+
+ )?
+ }imsx,
+);
+
+{
+ # Returns a singleton instance of Fcm::Build::Fortran.
+ my $FORTRAN_UTIL;
+ sub _get_fortran_util {
+ $FORTRAN_UTIL ||= Fcm::Build::Fortran->new();
+ return $FORTRAN_UTIL;
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $obj = Fcm::BuildSrc->new (%args);
+#
+# DESCRIPTION
+# This method constructs a new instance of the Fcm::BuildSrc class. See
+# above for allowed list of properties. (KEYS should be in uppercase.)
+# ------------------------------------------------------------------------------
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = bless(Fcm::Base->new(%args), $class);
+ for my $key (@scalar_properties, @hash_properties) {
+ $self->{$key}
+ = exists($args{uc($key)}) ? $args{uc($key)}
+ : undef
+ ;
+ }
+ $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @scalar_properties.
+# ------------------------------------------------------------------------------
+
+for my $name (@scalar_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my $self = shift;
+
+ # Argument specified, set property to specified argument
+ if (@_) {
+ $self->{$name} = $_[0];
+
+ if ($name eq 'ppsrc') {
+ $self->ppmtime (undef);
+
+ } elsif ($name eq 'src') {
+ $self->mtime (undef);
+ }
+ }
+
+ # Default value for property
+ if (not defined $self->{$name}) {
+ if ($name eq 'children') {
+ # Reference to an empty array
+ $self->{$name} = [];
+
+ } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) {
+ # Empty string
+ $self->{$name} = '';
+
+ } elsif ($name eq 'mtime') {
+ # Modification time
+ $self->{$name} = (stat $self->src)[9] if $self->src;
+
+ } elsif ($name eq 'ppmtime') {
+ # Modification time
+ $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc;
+
+ } elsif ($name eq 'type') {
+ # Attempt to get the type if src is set
+ $self->{$name} = $self->get_type if $self->src;
+ }
+ }
+
+ return $self->{$name};
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# %hash = %{ $obj->X () };
+# $obj->X (\%hash);
+#
+# $value = $obj->X ($index);
+# $obj->X ($index, $value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @hash_properties.
+#
+# If no argument is set, this method returns a hash containing a list of
+# objects. If an argument is set and it is a reference to a hash, the objects
+# are replaced by the the specified hash.
+#
+# If a scalar argument is specified, this method returns a reference to an
+# object, if the indexed object exists or undef if the indexed object does
+# not exist. If a second argument is set, the $index element of the hash will
+# be set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+for my $name (@hash_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my ($self, $arg1, $arg2) = @_;
+
+ # Ensure property is defined as a reference to a hash
+ if (not defined $self->{$name}) {
+ if ($name eq 'rules') {
+ $self->{$name} = $self->get_rules;
+
+ } else {
+ $self->{$name} = {};
+ }
+ }
+
+ # Argument 1 can be a reference to a hash or a scalar index
+ my ($index, %hash);
+
+ if (defined $arg1) {
+ if (ref ($arg1) eq 'HASH') {
+ %hash = %$arg1;
+
+ } else {
+ $index = $arg1;
+ }
+ }
+
+ if (defined $index) {
+ # A scalar index is defined, set and/or return the value of an element
+ $self->{$name}{$index} = $arg2 if defined $arg2;
+
+ return (
+ exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
+ );
+
+ } else {
+ # A scalar index is not defined, set and/or return the hash
+ $self->{$name} = \%hash if defined $arg1;
+ return $self->{$name};
+ }
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# This method returns/sets property X, all derived from src, where X is:
+# base - (read-only) basename of src
+# dir - (read-only) dirname of src
+# ext - (read-only) file extension of src
+# root - (read-only) basename of src without the file extension
+# ------------------------------------------------------------------------------
+
+sub base {
+ return &basename ($_[0]->src);
+}
+
+# ------------------------------------------------------------------------------
+
+sub dir {
+ return &dirname ($_[0]->src);
+}
+
+# ------------------------------------------------------------------------------
+
+sub ext {
+ return substr $_[0]->base, length ($_[0]->root);
+}
+
+# ------------------------------------------------------------------------------
+
+sub root {
+ (my $root = $_[0]->base) =~ s/\.\w+$//;
+ return $root;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# This method returns/sets property X, all derived from ppsrc, where X is:
+# ppbase - (read-only) basename of ppsrc
+# ppdir - (read-only) dirname of ppsrc
+# ppext - (read-only) file extension of ppsrc
+# pproot - (read-only) basename of ppsrc without the file extension
+# ------------------------------------------------------------------------------
+
+sub ppbase {
+ return &basename ($_[0]->ppsrc);
+}
+
+# ------------------------------------------------------------------------------
+
+sub ppdir {
+ return &dirname ($_[0]->ppsrc);
+}
+
+# ------------------------------------------------------------------------------
+
+sub ppext {
+ return substr $_[0]->ppbase, length ($_[0]->pproot);
+}
+
+# ------------------------------------------------------------------------------
+
+sub pproot {
+ (my $root = $_[0]->ppbase) =~ s/\.\w+$//;
+ return $root;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+#
+# DESCRIPTION
+# This method returns/sets property X, derived from src or ppsrc, where X is:
+# curbase - (read-only) basename of cursrc
+# curdir - (read-only) dirname of cursrc
+# curext - (read-only) file extension of cursrc
+# curmtime - (read-only) modification time of cursrc
+# curroot - (read-only) basename of cursrc without the file extension
+# cursrc - ppsrc or src
+# ------------------------------------------------------------------------------
+
+for my $name (qw/base dir ext mtime root src/) {
+ no strict 'refs';
+
+ my $subname = 'cur' . $name;
+
+ *$subname = sub {
+ my $self = shift;
+ my $method = $self->ppsrc ? 'pp' . $name : $name;
+ return $self->$method (@_);
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $base = $obj->X ();
+#
+# DESCRIPTION
+# This method returns a basename X for the source, where X is:
+# donebase - "done" file name
+# etcbase - target for copying data files
+# exebase - executable name for source containing a main program
+# interfacebase - Fortran interface file name
+# libbase - library file name
+# objbase - object name for source containing compilable source
+# If the source file contains a compilable procedure, this method returns
+# the name of the object file.
+# ------------------------------------------------------------------------------
+
+sub donebase {
+ my $self = shift;
+
+ my $return;
+ if ($self->is_type_all ('SOURCE')) {
+ if ($self->objbase and not $self->is_type_all ('PROGRAM')) {
+ $return = ($self->progname ? $self->progname : lc ($self->curroot)) .
+ $self->setting (qw/OUTFILE_EXT DONE/);
+ }
+
+ } elsif ($self->is_type_all ('INCLUDE')) {
+ $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/);
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+
+sub etcbase {
+ my $self = shift;
+
+ my $return = @{ $self->children }
+ ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/)
+ : undef;
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+
+sub exebase {
+ my $self = shift;
+
+ my $return;
+ if ($self->objbase and $self->is_type_all ('PROGRAM')) {
+ if ($self->setting ('BLD_EXE_NAME', $self->curroot)) {
+ $return = $self->setting ('BLD_EXE_NAME', $self->curroot);
+
+ } else {
+ $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/);
+ }
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+
+sub interfacebase {
+ my $self = shift();
+ if (
+ uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE'
+ && $self->progname()
+ && $self->is_type_all(qw/SOURCE/)
+ && $self->is_type_any(qw/FORTRAN9X FPP9X/)
+ && !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/)
+ ) {
+ my $flag = lc($self->get_setting(qw/TOOL INTERFACE/));
+ my $ext = $self->setting(qw/OUTFILE_EXT INTERFACE/);
+
+ return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext);
+ }
+ return;
+}
+
+# ------------------------------------------------------------------------------
+
+sub objbase {
+ my $self = shift;
+
+ my $return;
+
+ if ($self->is_type_all ('SOURCE')) {
+ my $ext = $self->setting (qw/OUTFILE_EXT OBJ/);
+
+ if ($self->is_type_any (qw/FORTRAN FPP/)) {
+ $return = lc ($self->progname) . $ext if $self->progname;
+
+ } else {
+ $return = lc ($self->curroot) . $ext;
+ }
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->flagsbase ($flag, [$index,]);
+#
+# DESCRIPTION
+# This method returns the property flagsbase (derived from pkgname) the base
+# name of the flags-file (to indicate changes in a particular build tool) for
+# $flag, which can have the value:
+# *FLAGS - compiler flags flags-file
+# *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file
+# LD - linker flags-file
+# LDFLAGS - linker flags flags-file
+# If $index is set, the $index'th element in pkgnames is used for the package
+# name.
+# ------------------------------------------------------------------------------
+
+sub flagsbase {
+ my ($self, $flag, $index) = @_;
+
+ (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//;
+
+ if ($self->is_type_all ('SOURCE')) {
+ if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) {
+ my %tool_src = %{ $self->setting ('TOOL_SRC') };
+ $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : '';
+ }
+ }
+
+ if ($flag) {
+ return join ('__', ($flag, $pkg ? $pkg : ())) .
+ $self->setting (qw/OUTFILE_EXT FLAGS/);
+
+ } else {
+ return undef;
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->libbase ([$prefix], [$suffix]);
+#
+# DESCRIPTION
+# This method returns the property libbase (derived from pkgname) the base
+# name of the library archive. $prefix and $suffix defaults to 'lib' and '.a'
+# respectively.
+# ------------------------------------------------------------------------------
+
+sub libbase {
+ my ($self, $prefix, $suffix) = @_;
+ $prefix ||= 'lib';
+ $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/);
+ if ($self->src()) { # applies to directories only
+ return;
+ }
+ my $name = $self->setting('BLD_LIB', $self->pkgname());
+ if (!defined($name)) {
+ $name = $self->pkgname();
+ }
+ $prefix . $name . $suffix;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->lang ([$setting]);
+#
+# DESCRIPTION
+# This method returns the property lang (derived from type) the programming
+# language name if type matches one supported in the TOOL_SRC setting. If
+# $setting is specified, use $setting instead of TOOL_SRC.
+# ------------------------------------------------------------------------------
+
+sub lang {
+ my ($self, $setting) = @_;
+
+ my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') };
+
+ my $return = undef;
+ for my $key (@keys) {
+ next unless $self->is_type_all ('SOURCE', $key);
+ $return = $key;
+ last;
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->pkgnames;
+#
+# DESCRIPTION
+# This method returns a list of container packages, derived from pkgname:
+# ------------------------------------------------------------------------------
+
+sub pkgnames {
+ my $self = shift;
+
+ my $return = [];
+ if ($self->pkgname) {
+ my @names = split (/__/, $self->pkgname);
+
+ for my $i (0 .. $#names) {
+ push @$return, join ('__', (@names[0 .. $i]));
+ }
+
+ unshift @$return, '';
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# %dep = %{$obj->get_dep()};
+# %dep = %{$obj->get_dep($flag)};
+#
+# DESCRIPTION
+# This method scans the current source file for dependencies and returns the
+# dependency hash (keys = dependencies, values = dependency types). If $flag
+# is specified, the config setting for $flag is used to determine the types of
+# types. Otherwise, those specified in 'BLD_TYPE_DEP' is used.
+# ------------------------------------------------------------------------------
+
+sub get_dep {
+ my ($self, $flag) = @_;
+ # Work out list of exclude for this file, using its sub-package name
+ my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')};
+ # Determine what dependencies are supported by this known type
+ my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')};
+ my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')};
+ my @dep_types = ();
+ if (!$self->get_setting('BLD_DEP_N')) {
+ DEP_TYPE:
+ while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) {
+ # Check if current file is a type of file requiring dependency scan
+ if (!$self->is_type_all($key)) {
+ next DEP_TYPE;
+ }
+ # Get list of dependency type for this file
+ for my $dep_type (split(/$Fcm::Config::DELIMITER/, $dep_type_string)) {
+ if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) {
+ push(@dep_types, $dep_type);
+ }
+ }
+ }
+ }
+
+ # Automatic dependencies
+ my %dep_of;
+ my $can_get_symbol # Also scan for program unit name in Fortran source
+ = !$flag
+ && $self->is_type_all('SOURCE')
+ && $self->is_type_any(qw/FPP FORTRAN/)
+ ;
+ my $has_read_file;
+ if ($can_get_symbol || @dep_types) {
+ my $handle = _open($self->cursrc());
+ LINE:
+ while (my $line = readline($handle)) {
+ chomp($line);
+ if ($line =~ qr{\A \s* \z}msx) { # empty lines
+ next LINE;
+ }
+ if ($can_get_symbol) {
+ my $symbol = _get_dep_symbol($line);
+ if ($symbol) {
+ $self->progname($symbol);
+ $can_get_symbol = 0;
+ next LINE;
+ }
+ }
+ DEP_TYPE:
+ for my $dep_type (@dep_types) {
+ my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i;
+ if (!$match) {
+ next DEP_TYPE;
+ }
+ # $match may contain multiple items delimited by space
+ for my $item (split(qr{\s+}msx, $match)) {
+ my $key = uc($dep_type . $Fcm::Config::DELIMITER . $item);
+ if (!exists($EXCLUDE_SET{$key})) {
+ $dep_of{$item} = $dep_type;
+ }
+ }
+ next LINE;
+ }
+ }
+ $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of)));
+ close($handle);
+ $has_read_file = 1;
+ }
+
+ # Manual dependencies
+ my $manual_deps_ref
+ = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname());
+ if (defined($manual_deps_ref)) {
+ for (@{$manual_deps_ref}) {
+ my ($dep_type, $item) = split(/$Fcm::Config::DELIMITER/, $_, 2);
+ $dep_of{$item} = $dep_type;
+ }
+ }
+
+ return ($has_read_file, \%dep_of);
+}
+
+# Returns, if possible, the program unit declared in the $line.
+sub _get_dep_symbol {
+ my $line = shift();
+ for my $pattern (
+ qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE \s+ ([A-Za-z]\w*)}imsx,
+ qr{\A \s* MODULE (?!\s+PROCEDURE) \s+ ([A-Za-z]\w*)}imsx,
+ qr{\A \s* PROGRAM \s+ ([A-Za-z]\w*)}imsx,
+ qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx,
+ qr{\A \s* BLOCK\s*DATA \s+ ([A-Za-z]\w*)}imsx,
+ ) {
+ my ($match) = $line =~ $pattern;
+ if ($match) {
+ return lc($match);
+ }
+ }
+ return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# @out = @{ $obj->get_fortran_interface () };
+#
+# DESCRIPTION
+# This method invokes the Fortran interface block generator to generate
+# an interface block for the current source file. It returns a reference to
+# an array containing the lines of the interface block.
+# ------------------------------------------------------------------------------
+
+sub get_fortran_interface {
+ my $self = shift();
+ my %ACTION_OF = (
+ q{} => \&_get_fortran_interface_by_internal_code,
+ f90aib => \&_get_fortran_interface_by_f90aib,
+ none => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []},
+ );
+ my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/));
+ if (!$key || !exists($ACTION_OF{$key})) {
+ $key = q{};
+ }
+ $ACTION_OF{$key}->($self->cursrc());
+}
+
+# Generates Fortran interface block using "f90aib".
+sub _get_fortran_interface_by_f90aib {
+ my $path = shift();
+ my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull());
+ my $pipe = _open($command, '-|');
+ my @lines = readline($pipe);
+ close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?);
+ \@lines;
+}
+
+# Generates Fortran interface block using internal code.
+sub _get_fortran_interface_by_internal_code {
+ my $path = shift();
+ my $handle = _open($path);
+ my @lines = _get_fortran_util()->extract_interface($handle);
+ close($handle);
+ \@lines;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# @out = @{ $obj->get_pre_process () };
+#
+# DESCRIPTION
+# This method invokes the pre-processor on the source file and returns a
+# reference to an array containing the lines of the pre-processed source on
+# success.
+# ------------------------------------------------------------------------------
+
+sub get_pre_process {
+ my $self = shift;
+
+ # Supported source files
+ my $lang = $self->lang ('TOOL_SRC_PP');
+ return unless $lang;
+
+ # List of include directories
+ my @inc = @{ $self->setting (qw/PATH INC/) };
+
+ # Build the pre-processor command according to file type
+ my %tool = %{ $self->setting ('TOOL') };
+ my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) };
+
+ # The pre-processor command and its options
+ my @command = ($tool{$tool_src_pp{COMMAND}});
+ my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS});
+
+ # List of defined macros, add "-D" in front of each macro
+ my @ppkeys = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS});
+ @ppkeys = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys;
+
+ # Add "-I" in front of each include directories
+ @inc = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc;
+
+ push @command, (@ppflags, @ppkeys, @inc, $self->base);
+
+ # Change to container directory of source file
+ my $old_cwd = $self->_chdir($self->dir());
+
+ # Execute the command, getting the output lines
+ my $verbose = $self->verbose;
+ my @outlines = &run_command (
+ \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
+ );
+
+ # Change back to original directory
+ $self->_chdir($old_cwd);
+
+ return \@outlines;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rules = %{ $self->get_rules };
+#
+# DESCRIPTION
+# This method returns a reference to a hash in the following format:
+# $rules = {
+# target => {ACTION => action, DEP => [dependencies], ...},
+# ... => {...},
+# };
+# where the 1st rank keys are the available targets for building this source
+# file, the second rank keys are ACTION and DEP. The value of ACTION is the
+# action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
+# "CP" or "AR". The value of DEP is a refernce to an array containing a list
+# of dependencies suitable for insertion into the Makefile.
+# ------------------------------------------------------------------------------
+
+sub get_rules {
+ my $self = shift;
+
+ my $rules;
+ my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') };
+
+ if ($self->is_type_all (qw/SOURCE/)) {
+ # Source file
+ # --------------------------------------------------------------------------
+ # Determine whether the language of the source file is supported
+ my %tool_src = %{ $self->setting ('TOOL_SRC') };
+
+ return () unless $self->lang;
+
+ # Compile object
+ # --------------------------------------------------------------------------
+ if ($self->objbase) {
+ # Depends on the source file
+ my @dep = ($self->rule_src);
+
+ # Depends on the compiler flags flags-file
+ my @flags;
+ push @flags, ('FLAGS' )
+ if $self->flagsbase ('FLAGS' );
+ push @flags, ('PPKEYS')
+ if $self->flagsbase ('PPKEYS') and not $self->ppsrc;
+
+ push @dep, $self->flagsbase ($_) for (@flags);
+
+ # Source file dependencies
+ for my $name (sort keys %{ $self->dep }) {
+ # A Fortran 9X module, lower case object file name
+ if ($self->dep ($name) eq 'USE') {
+ (my $root = $name) =~ s/\.\w+$//;
+ push @dep, lc ($root) . $outfile_ext{OBJ};
+
+ # An include file
+ } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
+ push @dep, $name;
+ }
+ }
+
+ $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};
+
+ # Touch flags-files
+ # ------------------------------------------------------------------------
+ for my $flag (@flags) {
+ next unless $self->flagsbase ($flag);
+
+ $rules->{$self->flagsbase ($flag)} = {
+ ACTION => 'TOUCH',
+ DEP => [
+ $self->flagsbase ($tool_src{$self->lang}{$flag}, -2),
+ ],
+ DEST => '$(FCM_FLAGSDIR)',
+ };
+ }
+ }
+
+ if ($self->exebase) {
+ # Link into an executable
+ # ------------------------------------------------------------------------
+ my @dep = ();
+ push @dep, $self->objbase if $self->objbase;
+ push @dep, $self->flagsbase ('LD' ) if $self->flagsbase ('LD' );
+ push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');
+
+ # Depends on BLOCKDATA program units, for Fortran programs
+ my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') };
+ my @blkobj = ();
+
+ if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) {
+ # List of BLOCKDATA object files
+ if (exists $blockdata{$self->exebase}) {
+ @blkobj = split /\s+/, $blockdata{$self->exebase};
+
+ } elsif (exists $blockdata{''}) {
+ @blkobj = split /\s+/, $blockdata{''};
+ }
+
+ for my $name (@blkobj) {
+ (my $root = $name) =~ s/\.\w+$//;
+ $name = $root . $outfile_ext{OBJ};
+ push @dep, $root . $outfile_ext{DONE};
+ }
+ }
+
+ # Extra executable dependencies
+ my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') };
+ if (keys %exe_dep) {
+ my @exe_deps;
+ if (exists $exe_dep{$self->exebase}) {
+ @exe_deps = split /\s+/, $exe_dep{$self->exebase};
+
+ } elsif (exists $exe_dep{''}) {
+ @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : ('');
+ }
+
+ my $pattern = '\\' . $outfile_ext{OBJ} . '$';
+
+ for my $name (@exe_deps) {
+ if ($name =~ /$pattern/) {
+ # Extra dependency is an object
+ (my $root = $name) =~ s/\.\w+$//;
+ push @dep, $root . $outfile_ext{DONE};
+
+ } else {
+ # Extra dependency is a sub-package
+ my $var;
+ if ($self->setting ('FCM_PCK_OBJECTS', $name)) {
+ # sub-package name contains unusual characters
+ $var = $self->setting ('FCM_PCK_OBJECTS', $name);
+
+ } else {
+ # sub-package name contains normal characters
+ $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
+ }
+
+ push @dep, '$(' . $var . ')';
+ }
+ }
+ }
+
+ # Source file dependencies
+ for my $name (sort keys %{ $self->dep }) {
+ (my $root = $name) =~ s/\.\w+$//;
+
+ # Lowercase name for object dependency
+ $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
+
+ # Select "done" file extension
+ if ($self->dep ($name) =~ /^(?:INC|H)$/) {
+ push @dep, $name . $outfile_ext{IDONE};
+
+ } else {
+ push @dep, $root . $outfile_ext{DONE};
+ }
+ }
+
+ $rules->{$self->exebase} = {
+ ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
+ };
+
+ # Touch Linker flags-file
+ # ------------------------------------------------------------------------
+ for my $flag (qw/LD LDFLAGS/) {
+ $rules->{$self->flagsbase ($flag)} = {
+ ACTION => 'TOUCH',
+ DEP => [$self->flagsbase ($flag, -2)],
+ DEST => '$(FCM_FLAGSDIR)',
+ };
+ }
+
+ }
+
+ if ($self->donebase) {
+ # Touch done file
+ # ------------------------------------------------------------------------
+ my @dep = ($self->objbase);
+
+ for my $name (sort keys %{ $self->dep }) {
+ (my $root = $name) =~ s/\.\w+$//;
+
+ # Lowercase name for object dependency
+ $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
+
+ # Select "done" file extension
+ if ($self->dep ($name) =~ /^(?:INC|H)$/) {
+ push @dep, $name . $outfile_ext{IDONE};
+
+ } else {
+ push @dep, $root . $outfile_ext{DONE};
+ }
+ }
+
+ $rules->{$self->donebase} = {
+ ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
+ };
+ }
+
+ if ($self->interfacebase) {
+ # Interface target
+ # ------------------------------------------------------------------------
+ # Source file dependencies
+ my @dep = ();
+ for my $name (sort keys %{ $self->dep }) {
+ # Depends on Fortran 9X modules
+ push @dep, lc ($name) . $outfile_ext{OBJ}
+ if $self->dep ($name) eq 'USE';
+ }
+
+ $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep};
+ }
+
+ } elsif ($self->is_type_all ('INCLUDE')) {
+ # Copy include target
+ # --------------------------------------------------------------------------
+ my @dep = ($self->rule_src);
+
+ for my $name (sort keys %{ $self->dep }) {
+ # A Fortran 9X module, lower case object file name
+ if ($self->dep ($name) eq 'USE') {
+ (my $root = $name) =~ s/\.\w+$//;
+ push @dep, lc ($root) . $outfile_ext{OBJ};
+
+ # An include file
+ } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) {
+ push @dep, $name;
+ }
+ }
+
+ $rules->{$self->curbase} = {
+ ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
+ };
+
+ # Touch IDONE file
+ # --------------------------------------------------------------------------
+ if ($self->donebase) {
+ my @dep = ($self->rule_src);
+
+ for my $name (sort keys %{ $self->dep }) {
+ (my $root = $name) =~ s/\.\w+$//;
+
+ # Lowercase name for object dependency
+ $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/;
+
+ # Select "done" file extension
+ if ($self->dep ($name) =~ /^(?:INC|H)$/) {
+ push @dep, $name . $outfile_ext{IDONE};
+
+ } else {
+ push @dep, $root . $outfile_ext{DONE};
+ }
+ }
+
+ $rules->{$self->donebase} = {
+ ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
+ };
+ }
+
+ } elsif ($self->is_type_any (qw/EXE SCRIPT/)) {
+ # Copy executable file
+ # --------------------------------------------------------------------------
+ my @dep = ($self->rule_src);
+
+ # Depends on dummy copy file, if file is an "always build type"
+ push @dep, $self->setting (qw/BLD_CPDUMMY/)
+ if $self->is_type_any (split (
+ /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD')
+ ));
+
+ # Depends on other executable files
+ for my $name (sort keys %{ $self->dep }) {
+ push @dep, $name if $self->dep ($name) eq 'EXE';
+ }
+
+ $rules->{$self->curbase} = {
+ ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
+ };
+
+ } elsif (@{ $self->children }) {
+ # Targets for top level and package flags files and dummy dependencies
+ # --------------------------------------------------------------------------
+ my %tool_src = %{ $self->setting ('TOOL_SRC') };
+ my %flags_tool = (LD => '', LDFLAGS => '');
+
+ for my $key (keys %tool_src) {
+ $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND}
+ if exists $tool_src{$key}{FLAGS};
+
+ $flags_tool{$tool_src{$key}{PPKEYS}} = ''
+ if exists $tool_src{$key}{PPKEYS};
+ }
+
+ for my $name (sort keys %flags_tool) {
+ my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2);
+ push @dep, $self->flagsbase ($flags_tool{$name})
+ if $self->pkgname eq '' and $flags_tool{$name};
+
+ $rules->{$self->flagsbase ($flags_tool{$name})} = {
+ ACTION => 'TOUCH',
+ DEST => '$(FCM_FLAGSDIR)',
+ } if $self->pkgname eq '' and $flags_tool{$name};
+
+ $rules->{$self->flagsbase ($name)} = {
+ ACTION => 'TOUCH',
+ DEP => \@dep,
+ DEST => '$(FCM_FLAGSDIR)',
+ };
+ }
+
+ # Package object and library
+ # --------------------------------------------------------------------------
+ {
+ my @dep;
+ # Add objects from children
+ for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) {
+ push @dep, $child->rule_obj_var (1)
+ if $child->libbase and $child->rules ($child->libbase);
+ push @dep, $child->objbase
+ if $child->cursrc and $child->objbase and
+ not $child->is_type_any (qw/PROGRAM BLOCKDATA/);
+ }
+
+ if (@dep) {
+ $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep};
+ }
+ }
+
+ # Package data files
+ # --------------------------------------------------------------------------
+ {
+ my @dep;
+ for my $child (@{ $self->children }) {
+ push @dep, $child->rule_src if $child->src and not $child->type;
+ }
+
+ if (@dep) {
+ push @dep, $self->setting (qw/BLD_CPDUMMY/);
+ $rules->{$self->etcbase} = {
+ ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)',
+ };
+ }
+ }
+ }
+
+ return $rules;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->get_setting ($setting[, @prefix]);
+#
+# DESCRIPTION
+# This method gets the correct $setting for the current source by following
+# its package name. If @prefix is set, get the setting with the given prefix.
+# ------------------------------------------------------------------------------
+
+sub get_setting {
+ my ($self, $setting, @prefix) = @_;
+
+ my $val;
+ for my $name (reverse @{ $self->pkgnames }) {
+ my @names = split /__/, $name;
+ $val = $self->setting ($setting, join ('__', (@prefix, @names)));
+
+ $val = $self->setting ($setting, join ('__', (@prefix, @names)))
+ if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//;
+ last if defined $val;
+ }
+
+ return $val;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $type = $self->get_type();
+#
+# DESCRIPTION
+# This method determines whether the source is a type known to the
+# build system. If so, it returns the type flags delimited by "::".
+# ------------------------------------------------------------------------------
+
+sub get_type {
+ my $self = shift();
+ my @IGNORE_LIST
+ = split(/$Fcm::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE'));
+ if (grep {$self->curbase() eq $_} @IGNORE_LIST) {
+ return q{};
+ }
+ # User defined
+ my $type = $self->setting('BLD_TYPE', $self->pkgname());
+ # Extension
+ if (!defined($type)) {
+ my $ext = $self->curext() ? substr($self->curext(), 1) : q{};
+ $type = $self->setting('INFILE_EXT', $ext);
+ }
+ # Pattern of name
+ if (!defined($type)) {
+ my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')};
+ PATTERN:
+ while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) {
+ if ($self->curbase() =~ $pattern) {
+ $type = $value;
+ last PATTERN;
+ }
+ }
+ }
+ # Pattern of #! line
+ if (!defined($type) && -s $self->cursrc() && -T _) {
+ my $handle = _open($self->cursrc());
+ my $line = readline($handle);
+ close($handle);
+ my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')};
+ PATTERN:
+ while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) {
+ if ($line =~ qr{^\#!.*$pattern}msx) {
+ $type = $value;
+ last PATTERN;
+ }
+ }
+ }
+ if (!$type) {
+ return $type;
+ }
+ # Extra type information for selected file types
+ my %EXTRA_FOR = (
+ qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran,
+ qr{\b C \b}msx => \&_get_type_extra_for_c,
+ );
+ EXTRA:
+ while (my ($key, $code_ref) = each(%EXTRA_FOR)) {
+ if ($type =~ $key) {
+ my $handle = _open($self->cursrc());
+ LINE:
+ while (my $line = readline($handle)) {
+ my $extra = $code_ref->($line);
+ if ($extra) {
+ $type .= $Fcm::Config::DELIMITER . $extra;
+ last LINE;
+ }
+ }
+ close($handle);
+ last EXTRA;
+ }
+ }
+ return $type;
+}
+
+sub _get_type_extra_for_fortran {
+ my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx;
+ if (!$match) {
+ return;
+ }
+ $match =~ s{\s}{}g;
+ uc($match)
+}
+
+sub _get_type_extra_for_c {
+ ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $flag = $obj->is_in_package ($name);
+#
+# DESCRIPTION
+# This method returns true if current package is in the package $name.
+# ------------------------------------------------------------------------------
+
+sub is_in_package {
+ my ($self, $name) = @_;
+
+ my $return = 0;
+ for (@{ $self->pkgnames }) {
+ next unless /^$name(?:\.\w+)?$/;
+ $return = 1;
+ last;
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $flag = $obj->is_type_all ($arg, ...);
+# $flag = $obj->is_type_any ($arg, ...);
+#
+# DESCRIPTION
+# This method returns a flag for the following:
+# is_type_all - does type match all of the arguments?
+# is_type_any - does type match any of the arguments?
+# ------------------------------------------------------------------------------
+
+for my $name ('all', 'any') {
+ no strict 'refs';
+
+ my $subname = 'is_type_' . $name;
+
+ *$subname = sub {
+ my ($self, @intypes) = @_;
+
+ my $rc = 0;
+ if ($self->type) {
+ my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type;
+
+ for my $intype (@intypes) {
+ $rc = exists $types{$intype};
+ last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc);
+ }
+ }
+
+ return $rc;
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $obj->rule_obj_var ([$read]);
+#
+# DESCRIPTION
+# This method returns a string containing the make rule object variable for
+# the current package. If $read is set, return $($string)
+# ------------------------------------------------------------------------------
+
+sub rule_obj_var {
+ my ($self, $read) = @_;
+
+ my $return;
+ if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) {
+ # Package name registered in unusual list
+ $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname);
+
+ } else {
+ # Package name not registered in unusual list
+ $return = $self->pkgname
+ ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS';
+ }
+
+ $return = $read ? '$(' . $return . ')' : $return;
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $obj->rule_src ();
+#
+# DESCRIPTION
+# This method returns a string containing the location of the source file
+# relative to the build root. This string will be suitable for use in a
+# "Make" rule file for FCM.
+# ------------------------------------------------------------------------------
+
+sub rule_src {
+ my $self = shift;
+
+ my $return = $self->cursrc;
+ LABEL: for my $name (qw/SRC PPSRC/) {
+ for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) {
+ my $dir = $self->setting ('PATH', $name)->[$i];
+ next unless index ($self->cursrc, $dir) == 0;
+
+ $return = File::Spec->catfile (
+ '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')',
+ File::Spec->abs2rel ($self->cursrc, $dir),
+ );
+ last LABEL;
+ }
+ }
+
+ return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $obj->write_lib_dep_excl ();
+#
+# DESCRIPTION
+# This method writes a set of exclude dependency configurations for the
+# library of this package.
+# ------------------------------------------------------------------------------
+
+sub write_lib_dep_excl {
+ my $self = shift();
+ if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) {
+ return 0;
+ }
+
+ my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0];
+ my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/);
+ my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL');
+ my @SETTINGS = (
+ #dependency #source file type list #dependency name function
+ ['H' , [qw{INCLUDE CPP }], sub {$_[0]->base()} ],
+ ['INTERFACE', [qw{INCLUDE INTERFACE }], sub {$_[0]->base()} ],
+ ['INC' , [qw{INCLUDE }], sub {$_[0]->base()} ],
+ ['USE' , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()} ],
+ ['INTERFACE', [qw{SOURCE FORTRAN }], sub {$_[0]->interfacebase()}],
+ ['OBJ' , [qw{SOURCE }], sub {$_[0]->root()} ],
+ );
+
+ my $cfg = Fcm::CfgFile->new();
+ my @stack = ($self);
+ NODE:
+ while (my $node = pop(@stack)) {
+ # Is a directory
+ if (@{$node->children()}) {
+ push(@stack, reverse(@{$node->children()}));
+ next NODE;
+ }
+ # Is a typed file
+ if (
+ $node->cursrc()
+ && $node->type()
+ && !$node->is_type_any(qw{PROGRAM BLOCKDATA})
+ ) {
+ for (@SETTINGS) {
+ my ($key, $type_list_ref, $name_func_ref) = @{$_};
+ my $name = $name_func_ref->($node);
+ if ($name && $node->is_type_all(@{$type_list_ref})) {
+ push(
+ @{$cfg->lines()},
+ Fcm::CfgLine->new(
+ label => $LABEL_OF_EXCL_DEP,
+ value => $key . $Fcm::Config::DELIMITER . $name,
+ ),
+ );
+ next NODE;
+ }
+ }
+ }
+ }
+
+ # Write to configuration file
+ $cfg->print_cfg(
+ File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)),
+ );
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $string = $obj->write_rules ();
+#
+# DESCRIPTION
+# This method returns a string containing the "Make" rules for building the
+# source file.
+# ------------------------------------------------------------------------------
+
+sub write_rules {
+ my $self = shift;
+ my $mk = '';
+
+ for my $target (sort keys %{ $self->rules }) {
+ my $rule = $self->rules ($target);
+ next unless defined ($rule->{ACTION});
+
+ if ($rule->{ACTION} eq 'AR') {
+ my $var = $self->rule_obj_var;
+ $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
+ $mk .= ' ' . join (' ', @{ $rule->{DEP} });
+ $mk .= "\n\n";
+ }
+
+ $mk .= $target . ':';
+
+ if ($rule->{ACTION} eq 'AR') {
+ $mk .= ' ' . $self->rule_obj_var (1);
+
+ } else {
+ for my $dep (@{ $rule->{DEP} }) {
+ $mk .= ' ' . $dep;
+ }
+ }
+
+ $mk .= "\n";
+
+ if (exists $rule->{ACTION}) {
+ if ($rule->{ACTION} eq 'AR') {
+ $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n";
+
+ } elsif ($rule->{ACTION} eq 'CP') {
+ $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n";
+ $mk .= "\t" . 'chmod u+w ' .
+ File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
+
+ } elsif ($rule->{ACTION} eq 'CP_DATA') {
+ $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n";
+ $mk .= "\t" . 'touch ' .
+ File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
+
+ } elsif ($rule->{ACTION} eq 'COMPILE') {
+ if ($self->lang) {
+ $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
+ ' ' . $self->pkgnames->[-2] . ' $< $@';
+ $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
+ $mk .= "\n";
+ }
+
+ } elsif ($rule->{ACTION} eq 'LOAD') {
+ if ($self->lang) {
+ $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) .
+ ' ' . $self->pkgnames->[-2] . ' $< $@';
+ $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} })
+ if @{ $rule->{BLOCKDATA} };
+ $mk .= "\n";
+ }
+
+ } elsif ($rule->{ACTION} eq 'TOUCH') {
+ $mk .= "\t" . 'touch ' .
+ File::Spec->catfile ($rule->{DEST}, '$@') . "\n";
+ }
+ }
+
+ $mk .= "\n";
+ }
+
+ return $mk;
+}
+
+# Wraps "chdir". Returns old directory.
+sub _chdir {
+ my ($self, $dir) = @_;
+ my $old_cwd = cwd();
+ $self->_event('CHDIR', $dir);
+ chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir));
+ $old_cwd;
+}
+
+# Wraps an event.
+sub _event {
+ my ($self, $key, @args) = @_;
+ my ($format, $level) = @{$EVENT_SETTING_OF{$key}};
+ $level ||= 1;
+ if ($self->verbose() >= $level) {
+ printf($format . ".\n", @args);
+ }
+}
+
+# Wraps "open".
+sub _open {
+ my ($path, $mode) = @_;
+ $mode ||= '<';
+ open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!));
+ $handle;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: NEMO/trunk/ext/FCM/lib/Fcm/BuildTask.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/BuildTask.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/BuildTask.pm (revision 9596)
@@ -0,0 +1,340 @@
+# ------------------------------------------------------------------------------
+# NAME
+# Fcm::BuildTask
+#
+# DESCRIPTION
+# This class hosts information of a build task in the FCM build system.
+#
+# COPYRIGHT
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::BuildTask;
+@ISA = qw(Fcm::Base);
+
+# Standard pragma
+use strict;
+use warnings;
+
+# Standard modules
+use Carp;
+use File::Compare;
+use File::Copy;
+use File::Basename;
+use File::Path;
+use File::Spec::Functions;
+
+# FCM component modules
+use Fcm::Base;
+use Fcm::Timer;
+use Fcm::Util;
+
+# List of property methods for this class
+my @scalar_properties = (
+ 'actiontype', # type of action
+ 'dependency', # list of dependencies for this target
+ 'srcfile', # reference to input Fcm::BuildSrc instance
+ 'output', # output file
+ 'outputmtime', # output file modification time
+ 'target', # target name for this task
+ 'targetpath', # search path for the target
+);
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $obj = Fcm::BuildTask->new (%args);
+#
+# DESCRIPTION
+# This method constructs a new instance of the Fcm::BuildTask class. See
+# above for allowed list of properties. (KEYS should be in uppercase.)
+# ------------------------------------------------------------------------------
+
+sub new {
+ my $this = shift;
+ my %args = @_;
+ my $class = ref $this || $this;
+
+ my $self = Fcm::Base->new (%args);
+
+ bless $self, $class;
+
+ for my $name (@scalar_properties) {
+ $self->{$name} = exists $args{uc ($name)} ? $args{uc ($name)} : undef;
+ }
+
+ return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $value = $obj->X;
+# $obj->X ($value);
+#
+# DESCRIPTION
+# Details of these properties are explained in @scalar_properties.
+# ------------------------------------------------------------------------------
+
+for my $name (@scalar_properties) {
+ no strict 'refs';
+
+ *$name = sub {
+ my $self = shift;
+
+ # Argument specified, set property to specified argument
+ if (@_) {
+ $self->{$name} = $_[0];
+
+ if ($name eq 'output') {
+ $self->{outputmtime} = $_[0] ? (stat $_[0]) [9] : undef;
+ }
+ }
+
+ # Default value for property
+ if (not defined $self->{$name}) {
+ if ($name eq 'dependency' or $name eq 'targetpath') {
+ # Reference to an array
+ $self->{$name} = [];
+ }
+ }
+
+ return $self->{$name};
+ }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+# $rc = $obj->action (TASKLIST => \%tasklist);
+#
+# DESCRIPTION
+# This method performs the task action and sets the output accordingly. The
+# argument TASKLIST must be a reference to a hash containing the other tasks
+# of the build, which this task may depend on. The keys of the hash must the
+# name of the target names of the tasks, and the values of the hash must be
+# the references to the corresponding Fcm::BuildTask instances. The method
+# returns true if the task has been performed to create a new version of the
+# target.
+# ------------------------------------------------------------------------------
+
+sub action {
+ my $self = shift;
+ my %args = @_;
+ my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {};
+
+ return unless $self->actiontype;
+
+ my $uptodate = 1;
+ my $dep_uptodate = 1;
+
+ # Check if dependencies are up to date
+ # ----------------------------------------------------------------------------
+ for my $depend (@{ $self->dependency }) {
+ if (exists $tasklist->{$depend}) {
+ if (not $tasklist->{$depend}->output) {
+ # Dependency task output is not set, performs its task action
+ if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) {
+ $uptodate = 0;
+ $dep_uptodate = 0;
+ }
+ }
+
+ } elsif ($self->verbose > 1) {
+ w_report 'Warning: Task for "', $depend,
+ '" does not exist, may be required by ', $self->target;
+ }
+ }
+
+ # Check if the target exists in the search path
+ # ----------------------------------------------------------------------------
+ if (@{ $self->targetpath }) {
+ my $output = find_file_in_path ($self->target, $self->targetpath);
+ $self->output ($output) if $output;
+ }
+
+ # Target is out of date if it does not exist
+ if ($uptodate) {
+ $uptodate = 0 if not $self->output;
+ }
+
+ # Check if current target is older than its dependencies
+ # ----------------------------------------------------------------------------
+ if ($uptodate) {
+ for my $depend (@{ $self->dependency }) {
+ next unless exists $tasklist->{$depend};
+
+ if ($tasklist->{$depend}->outputmtime > $self->outputmtime) {
+ $uptodate = 0;
+ $dep_uptodate = 0;
+ }
+ }
+
+ if ($uptodate and ref $self->srcfile) {
+ $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime;
+ }
+ }
+
+ if ($uptodate) {
+ # Current target and its dependencies are up to date
+ # --------------------------------------------------------------------------
+ if ($self->actiontype eq 'PP') {
+ # "done" file up to date, set name of pre-processed source file
+ # ------------------------------------------------------------------------
+ my $base = $self->srcfile->root . lc ($self->srcfile->ext);
+ my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2];
+ my @path = map {
+ catfile ($_, @pknames);
+ } @{ $self->setting (qw/PATH PPSRC/) };
+ my $oldfile = find_file_in_path ($base, \@path);
+ $self->srcfile->ppsrc ($oldfile);
+ }
+
+ } else {
+ # Perform action is not up to date
+ # --------------------------------------------------------------------------
+ # (For GENINTERFACE and PP, perform action if "done" file not up to date)
+ my $new_output = @{ $self->targetpath }
+ ? catfile ($self->targetpath->[0], $self->target)
+ : $self->target;
+
+ # Create destination container directory if necessary
+ my $destdir = dirname $new_output;
+
+ if (not -d $destdir) {
+ print 'Make directory: ', $destdir, "\n" if $self->verbose > 2;
+ mkpath $destdir;
+ }
+
+ # List of actions
+ if ($self->actiontype eq 'UPDATE') {
+ # Action is UPDATE: Update file
+ # ------------------------------------------------------------------------
+ print 'Update: ', $new_output, "\n" if $self->verbose > 2;
+ touch_file $new_output
+ or croak 'Unable to update "', $new_output, '", abort';
+ $self->output ($new_output);
+
+ } elsif ($self->actiontype eq 'COPY') {
+ # Action is COPY: copy file to destination if necessary
+ # ------------------------------------------------------------------------
+ my $copy_required = ($dep_uptodate and $self->output and -r $self->output)
+ ? compare ($self->output, $self->srcfile->src)
+ : 1;
+
+ if ($copy_required) {
+ # Set up copy command
+ my $srcfile = $self->srcfile->src;
+ my $destfile = catfile ($destdir, basename($srcfile));
+ print 'Copy: ', $srcfile, "\n", ' to: ', $destfile, "\n"
+ if $self->verbose > 2;
+ © ($srcfile, $destfile)
+ or die $srcfile, ': copy to ', $destfile, ' failed (', $!, '), abort';
+ chmod (((stat ($srcfile))[2] & 07777), $destfile);
+
+ $self->output ($new_output);
+
+ } else {
+ $uptodate = 1;
+ }
+
+ } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') {
+ # Action is PP or GENINTERFACE: process file
+ # ------------------------------------------------------------------------
+ my ($newlines, $base, @path);
+
+ if ($self->actiontype eq 'PP') {
+ # Invoke the pre-processor on the source file
+ # ----------------------------------------------------------------------
+ # Get lines in the pre-processed source
+ $newlines = $self->srcfile->get_pre_process;
+ $base = $self->srcfile->root . lc ($self->srcfile->ext);
+
+ # Get search path for the existing pre-processed file
+ my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2];
+ @path = map {
+ catfile ($_, @pknames);
+ } @{ $self->setting (qw/PATH PPSRC/) };
+
+ } else { # if ($self->actiontype eq 'GENINTERFACE')
+ # Invoke the interface generator
+ # ----------------------------------------------------------------------
+ # Get new interface lines
+ $newlines = $self->srcfile->get_fortran_interface;
+
+ # Get search path for the existing interface file
+ $base = $self->srcfile->interfacebase;
+ @path = @{ $self->setting (qw/PATH INC/) },
+ }
+
+
+ # If pre-processed or interface file exists,
+ # compare its content with new lines to see if it has been updated
+ my $update_required = 1;
+ my $oldfile = find_file_in_path ($base, \@path);
+
+ if ($oldfile and -r $oldfile) {
+ # Read old file
+ open FILE, '<', $oldfile;
+ my @oldlines = readline 'FILE';
+ close FILE;
+
+ # Compare old contents and new contents
+ if (@oldlines eq @$newlines) {
+ $update_required = grep {
+ $oldlines[$_] ne $newlines->[$_];
+ } (0 .. $#oldlines);
+ }
+ }
+
+ if ($update_required) {
+ # Update the pre-processed source or interface file
+ # ----------------------------------------------------------------------
+ # Determine container directory of the pre-processed or interface file
+ my $newfile = @path ? catfile ($path[0], $base) : $base;
+
+ # Create the container directory if necessary
+ if (not -d $path[0]) {
+ print 'Make directory: ', $path[0], "\n"
+ if $self->verbose > 1;
+ mkpath $path[0];
+ }
+
+ # Update the pre-processor or interface file
+ open FILE, '>', $newfile
+ or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
+ print FILE @$newlines;
+ close FILE
+ or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
+ print 'Generated: ', $newfile, "\n" if $self->verbose > 1;
+
+ # Set the name of the pre-processed file
+ $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP';
+
+ } else {
+ # Content in pre-processed source or interface file is up to date
+ # ----------------------------------------------------------------------
+ $uptodate = 1;
+
+ # Set the name of the pre-processed file
+ $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP';
+ }
+
+ # Update the "done" file
+ print 'Update: ', $new_output, "\n" if $self->verbose > 2;
+ touch_file $new_output
+ or croak 'Unable to update "', $new_output, '", abort';
+ $self->output ($new_output);
+
+ } else {
+ carp 'Action type "', $self->actiontype, "' not supported";
+ }
+ }
+
+ return not $uptodate;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI.pm (revision 9596)
@@ -0,0 +1,172 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI;
+
+use Carp qw{croak};
+use Fcm::CLI::Config;
+use Fcm::CLI::Exception;
+use Fcm::Util::ClassLoader;
+use File::Basename qw{basename};
+use Getopt::Long qw{GetOptions};
+use Scalar::Util qw{blessed};
+
+################################################################################
+# Invokes the FCM command line interface
+sub invoke {
+ local(@ARGV) = @ARGV;
+ my $config = Fcm::CLI::Config->instance();
+ my $subcommand_name = @ARGV ? shift(@ARGV) : q{};
+ my $subcommand = $config->get_subcommand_of($subcommand_name);
+ eval {
+ if (!$subcommand) {
+ croak(Fcm::CLI::Exception->new({message => 'unknown command'}));
+ }
+ my ($opts_ref, $args_ref, $is_help) = _parse_argv_using($subcommand);
+ my ($invoker_class, $invoker);
+ if ($is_help) {
+ $invoker_class
+ = _load_invoker_class_of($config->get_subcommand_of(q{}));
+ $invoker = $invoker_class->new({
+ command => $subcommand_name,
+ arguments => [$subcommand_name],
+ });
+ }
+ else {
+ $invoker_class = _load_invoker_class_of($subcommand);
+ $invoker = $invoker_class->new({
+ command => $subcommand_name,
+ options => $opts_ref,
+ arguments => $args_ref,
+ (
+ $subcommand->get_invoker_config()
+ ? %{$subcommand->get_invoker_config()}
+ : ()
+ ),
+ });
+ }
+ $invoker->invoke();
+ };
+ if ($@) {
+ if (Fcm::CLI::Exception->caught($@)) {
+ die(sprintf(
+ qq{%s%s: %s\nType "%s help%s" for usage\n},
+ basename($0),
+ ($subcommand_name ? qq{ $subcommand_name} : q{}),
+ $@->get_message(),
+ basename($0),
+ defined($subcommand) ? qq{ $subcommand_name} : q{},
+ ));
+ }
+ else {
+ die($@);
+ }
+ }
+}
+
+################################################################################
+# Parses options in @ARGV using the options settings of a subcommand
+sub _parse_argv_using {
+ my ($subcommand) = @_;
+ my %options = ();
+ my $is_help = undef;
+ if (($subcommand->get_options())) {
+ my $problem = q{};
+ local($SIG{__WARN__}) = sub {
+ ($problem) = @_;
+ };
+ my $success = GetOptions(
+ \%options,
+ (map {$_->get_arg_for_getopt_long()} ($subcommand->get_options())),
+ );
+ if (!$success) {
+ croak(Fcm::CLI::Exception->new({message => sprintf(
+ "option parse failed: %s", $problem,
+ )}));
+ }
+
+ OPTION:
+ for my $option ($subcommand->get_options()) {
+ if (!exists($options{$option->get_name()})) {
+ next OPTION;
+ }
+ if ($option->is_help()) {
+ $is_help = 1;
+ }
+ if (
+ $option->has_arg() == $option->ARRAY_ARG
+ && $option->get_delimiter()
+ ) {
+ $options{$option->get_name()} = [split(
+ $option->get_delimiter(),
+ join(
+ $option->get_delimiter(),
+ @{$options{$option->get_name()}},
+ ),
+ )];
+ }
+ }
+ }
+ return (\%options, [@ARGV], $is_help);
+}
+
+################################################################################
+# Loads and returns the invoker class of a subcommand
+sub _load_invoker_class_of {
+ my ($subcommand) = @_;
+ my $invoker_class
+ = $subcommand->get_invoker_class() ? $subcommand->get_invoker_class()
+ : 'Fcm::CLI::Invoker'
+ ;
+ return Fcm::Util::ClassLoader::load($invoker_class);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI
+ Fcm::CLI::invoke();
+
+=head1 DESCRIPTION
+
+Invokes the FCM command line interface.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item invoke()
+
+Invokes the FCM command line interface.
+
+=back
+
+=head1 TO DO
+
+Move option/argument parsing to L?
+
+Use an OO interface?
+
+=head1 SEE ALSO
+
+L,
+L,
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config.pm (revision 9596)
@@ -0,0 +1,133 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Config;
+
+use Fcm::CLI::Config::Default;
+use List::Util qw{first};
+use Scalar::Util qw{blessed};
+
+my $INSTANCE;
+
+################################################################################
+# Class method: returns an instance of this class
+sub instance {
+ my ($class, $args_ref) = @_;
+ if ($args_ref || !$INSTANCE) {
+ $INSTANCE = bless({
+ core_subcommands => [@Fcm::CLI::Config::Default::CORE_SUBCOMMANDS],
+ vc_subcommands => [@Fcm::CLI::Config::Default::VC_SUBCOMMANDS],
+ (defined($args_ref) ? %{$args_ref} : ()),
+ }, $class);
+ }
+ return $INSTANCE;
+}
+
+################################################################################
+# Returns a subcommand matching $key
+sub get_subcommand_of {
+ my ($self, $key) = @_;
+ if (blessed($key) && $key->isa('Fcm::CLI::Subcommand')) {
+ return first {"$_" eq "$key"} ($self->get_subcommands());
+ }
+ else {
+ return first {$_->has_a_name($key)} ($self->get_subcommands());
+ }
+}
+
+################################################################################
+# Returns the subcommands
+sub get_subcommands {
+ my ($self) = @_;
+ my @return = ($self->get_core_subcommands(), $self->get_vc_subcommands());
+ return (wantarray() ? @return : \@return);
+}
+
+################################################################################
+# Returns the core subcommands
+sub get_core_subcommands {
+ my ($self) = @_;
+ return (
+ wantarray() ? @{$self->{core_subcommands}} : $self->{core_subcommands}
+ );
+}
+
+################################################################################
+# Returns the subcommands that are relevant only with a VC system
+sub get_vc_subcommands {
+ my ($self) = @_;
+ return (wantarray() ? @{$self->{vc_subcommands}} : $self->{vc_subcommands});
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Config
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Config;
+ $cli_config = Fcm::CLI::Config->instance();
+ $subcommand = $cli_config->get_subcommand_of($key);
+ @subcommands = $cli_config->get_subcommands();
+ @core_subcommands = $cli_config->get_core_subcommands();
+ @vc_subcommands = $cli_config->get_vc_subcommands();
+
+=head1 DESCRIPTION
+
+This class provides the configuration of the FCM command line interface.
+
+=head1 METHODS
+
+=over 4
+
+=item instance($arg_ref)
+
+Returns an instance of this class.
+
+Creates the instance on first call, or replaces it with a new one if $args_ref
+is defined in subsequent call. $args_ref should be a reference to a hash. The
+hash can contain I and I. Each of these
+settings should point to an array reference containing L
+objects. If the setting is unspecified, it uses the default from
+L.
+
+=item get_subcommand_of($key)
+
+Returns a L object matching the
+search $key. Returns undef if there is no match.
+
+=item get_subcommands()
+
+Short-hand for:
+ ($self->get_core_subcommands(), $self->get_vc_subcommands())
+
+=item get_core_subcommands()
+
+Returns the core subcommands.
+
+=item get_vc_subcommands()
+
+Returns the subcommands that are relevant only in the presence of a VC system.
+
+=back
+
+=head1 SEE ALSO
+
+L,
+L,
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config/Default.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config/Default.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Config/Default.pm (revision 9596)
@@ -0,0 +1,412 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Config::Default;
+
+use Fcm::CLI::Option;
+use Fcm::CLI::Subcommand;
+
+my %DESCRIPTION_OF = (
+ # --------------------------------------------------------------------------
+ BROWSER => <<'END_DESCRIPTION',
+If TARGET is specified, it must be a FCM URL keyword, a Subversion URL or the
+path to a local working copy. If not specified, the current working directory
+is assumed to be a working copy. If the --browser option is specified, the
+specified web browser command is used to launch the repository browser.
+Otherwise, it attempts to use the default browser from the configuration
+setting.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ BUILD => <<'END_DESCRIPTION',
+The path to a CFGFILE may be provided. Otherwise, the build system searches the
+default locations for a bld cfg file.
+
+If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed.
+
+If the option for full build is specified, the sub-directories created by
+previous builds will be removed, so that the current build can start cleanly.
+
+The -s option can be used to limit the actions performed by the build system up
+to a named stage. The stages are:
+ "1", "s" or "setup" - stage 1, setup
+ "2", "pp" or "pre_process" - stage 2, pre-process
+ "3", "gd" or "generate_dependency" - stage 3, generate dependency
+ "4", "gi" or "generate_interface" - stage 4, generate Fortran 9X interface
+ "5", "m", "make" - stage 5, make
+
+If a colon separated list of targets is specified using the -t option, the
+default targets specified in the configuration file will not be used.
+
+If archive mode is switched on, build sub-directories that are only used in the
+build process will be archived to TAR files. The default is off.
+
+If specified, the verbose level must be an integer greater than 0. Verbose
+level 0 is the quiet mode. Increasing the verbose level will increase the
+amount of diagnostic output.
+
+When a build is invoked, it sets up a lock file in the build root directory.
+The lock is normally removed at the end of the build. While the lock file is in
+place, the build commands invoked in the same root directory will fail. If
+you need to bypass this check for whatever reason, you can invoke the build
+system with the --ignore-lock option.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ CFG_PRINTER => <<'END_DESCRIPTION',
+If no option is specified, the output will be sent to standard output.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ EXTRACT => <<'END_DESCRIPTION',
+The path to a CFG file may be provided. Otherwise, the extract system searches
+the default locations for an ext cfg file.
+
+If no option is specified, the system will attempt an incremental extract where
+appropriate.
+
+If specified, the verbose level must be an integer greater than 0. Verbose
+level 0 is the quiet mode. Increasing the verbose level will increase the
+amount of diagnostic output.
+
+When an extract is invoked, it sets up a lock file in the extract destination
+root directory. The lock is normally removed at the end of the extract. While
+the lock file is in place, other extract commands invoked in the same
+destination root directory will fail. If you need to bypass this check for
+whatever reason, you can invoke the extract system with the --ignore-lock
+option.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ EXTRACT_CONFIG_COMPARATOR => <<'END_DESCRIPTION',
+Compares the extract configurations of two similar extract configuration files
+CFGFILE1 and CFGFILE2.
+
+In normal mode with verbosity level 2 or above, displays the change log of each
+revision.
+
+In wiki mode, print revision tables in wiki format. The argument to the --wiki
+option must be the Subversion URL or FCM URL keyword of a FCM project
+associated with the intended Trac system. The --verbose option has no effect
+in wiki mode.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ GUI => <<'END_DESCRIPTION',
+The optional argument PATH modifies the initial working directory of the GUI.
+END_DESCRIPTION
+ # --------------------------------------------------------------------------
+ KEYWORD => <<'END_DESCRIPTION',
+If no argument is specified, prints registered location keywords. Otherwise,
+prints the implied location keywords and revision keywords for the specified
+target.
+END_DESCRIPTION
+);
+
+my %OPTION_OF = (
+ ARCHIVE => Fcm::CLI::Option->new({
+ name => 'archive',
+ letter => 'a',
+ description => 'archives sub-directories on success',
+ }),
+
+ BROWSER => Fcm::CLI::Option->new({
+ name => 'browser',
+ letter => 'b',
+ description => 'specifies the web browser command',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+
+ CLEAN => Fcm::CLI::Option->new({
+ name => 'clean',
+ description => 'cleans the destination',
+ }),
+
+ FULL => Fcm::CLI::Option->new({
+ name => 'full',
+ letter => 'f',
+ description => 'runs in full mode',
+ }),
+
+ HELP => Fcm::CLI::Option->new({
+ name => 'help',
+ letter => 'h',
+ description => 'prints help',
+ is_help => 1,
+ }),
+
+ IGNORE_LOCK => Fcm::CLI::Option->new({
+ name => 'ignore-lock',
+ description => 'ignores lock file',
+ }),
+
+ JOBS => Fcm::CLI::Option->new({
+ name => 'jobs',
+ letter => 'j',
+ description => 'number of parallel jobs',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+
+ OUTPUT => Fcm::CLI::Option->new({
+ name => 'output',
+ letter => 'o',
+ description => 'sends output to the specified file',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+
+ STAGE => Fcm::CLI::Option->new({
+ name => 'stage',
+ letter => 's',
+ description => 'runs command up to a named stage',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+
+ TARGETS => Fcm::CLI::Option->new({
+ name => 'targets',
+ letter => 't',
+ delimiter => ':',
+ description => 'list of build targets, delimited by (:)',
+ has_arg => Fcm::CLI::Option->ARRAY_ARG,
+ }),
+
+ VERBOSITY => Fcm::CLI::Option->new({
+ name => 'verbose',
+ letter => 'v',
+ description => 'verbose level',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+
+ WIKI => Fcm::CLI::Option->new({
+ name => 'wiki',
+ letter => 'w',
+ description => 'print revision tables in wiki format',
+ has_arg => Fcm::CLI::Option->SCALAR_ARG,
+ }),
+);
+
+my %SUBCOMMAND_OF = (
+ BRANCH => Fcm::CLI::Subcommand->new({
+ names => ['branch', 'br'],
+ synopsis => 'branch utilities',
+ invoker_class => 'Fcm::CLI::Invoker::CM',
+ is_vc => 1,
+ }),
+
+ BROWSER => Fcm::CLI::Subcommand->new({
+ names => ['trac', 'www'],
+ synopsis => 'invokes the browser for a version controlled target',
+ usage => '[OPTIONS...] [TARGET]',
+ description => $DESCRIPTION_OF{BROWSER},
+ invoker_class => 'Fcm::CLI::Invoker::Browser',
+ options => [
+ $OPTION_OF{BROWSER},
+ $OPTION_OF{HELP},
+ ],
+ }),
+
+ BUILD => Fcm::CLI::Subcommand->new({
+ names => ['build', 'bld'],
+ synopsis => 'invokes the build system',
+ usage => '[OPTIONS...] [CFGFILE]',
+ description => $DESCRIPTION_OF{BUILD},
+ invoker_class => 'Fcm::CLI::Invoker::ConfigSystem',
+ invoker_config => {
+ impl_class => 'Fcm::Build',
+ cli2invoke_key_map => {
+ 'archive' => 'ARCHIVE',
+ 'clean' => 'CLEAN',
+ 'full' => 'FULL',
+ 'ignore-lock' => 'IGNORE_LOCK',
+ 'jobs' => 'JOBS',
+ 'stage' => 'STAGE',
+ 'targets' => 'TARGETS',
+ },
+ },
+ options => [
+ $OPTION_OF{ARCHIVE},
+ $OPTION_OF{CLEAN},
+ $OPTION_OF{FULL},
+ $OPTION_OF{HELP},
+ $OPTION_OF{IGNORE_LOCK},
+ $OPTION_OF{JOBS},
+ $OPTION_OF{STAGE},
+ $OPTION_OF{TARGETS},
+ $OPTION_OF{VERBOSITY},
+ ],
+ }),
+
+ CFG_PRINTER => Fcm::CLI::Subcommand->new({
+ names => ['cfg'],
+ synopsis => 'invokes the CFG file pretty printer',
+ usage => '[OPTIONS...] [CFGFILE]',
+ description => $DESCRIPTION_OF{CFG_PRINTER},
+ invoker_class => 'Fcm::CLI::Invoker::CfgPrinter',
+ options => [
+ $OPTION_OF{HELP},
+ $OPTION_OF{OUTPUT},
+ ],
+ }),
+
+ CM => Fcm::CLI::Subcommand->new({
+ names => [qw{
+ add
+ blame praise annotate ann
+ cat
+ checkout co
+ cleanup
+ commit ci
+ copy cp
+ delete del remove rm
+ diff di
+ export
+ import
+ info
+ list ls
+ lock
+ log
+ merge
+ mkdir
+ move mv rename ren
+ propdel pdel pd
+ propedit pedit pe
+ propget pget pg
+ proplist plist pl
+ propset pset ps
+ resolved
+ revert
+ status stat st
+ switch sw
+ unlock
+ update up
+ }],
+ invoker_class => 'Fcm::CLI::Invoker::CM',
+ is_vc => 1,
+ }),
+
+ CONFLICTS => Fcm::CLI::Subcommand->new({
+ names => ['conflicts', 'cf'],
+ synopsis => 'resolves conflicts in your working copy',
+ usage => '[PATH]',
+ invoker_class => 'Fcm::CLI::Invoker::CM',
+ is_vc => 1,
+ }),
+
+ EXTRACT => Fcm::CLI::Subcommand->new({
+ names => ['extract', 'ext'],
+ synopsis => 'invokes the extract system',
+ usage => '[OPTIONS...] [CFGFILE]',
+ description => $DESCRIPTION_OF{EXTRACT},
+ invoker_class => 'Fcm::CLI::Invoker::ConfigSystem',
+ invoker_config => {
+ impl_class => 'Fcm::Extract',
+ cli2invoke_key_map => {
+ 'clean' => 'CLEAN',
+ 'full' => 'FULL',
+ 'ignore-lock' => 'IGNORE_LOCK',
+ },
+ },
+ options => [
+ $OPTION_OF{CLEAN},
+ $OPTION_OF{FULL},
+ $OPTION_OF{HELP},
+ $OPTION_OF{IGNORE_LOCK},
+ $OPTION_OF{VERBOSITY},
+ ],
+ }),
+
+ EXTRACT_CONFIG_COMPARATOR => Fcm::CLI::Subcommand->new({
+ names => ['cmp-ext-cfg'],
+ synopsis => 'invokes the extract configuration files comparator',
+ usage => '[OPTIONS...] CFGFILE1 CFGFILE2',
+ description => $DESCRIPTION_OF{EXTRACT_CONFIG_COMPARATOR},
+ invoker_class => 'Fcm::CLI::Invoker::ExtractConfigComparator',
+ options => [
+ $OPTION_OF{HELP},
+ $OPTION_OF{VERBOSITY},
+ $OPTION_OF{WIKI},
+ ],
+ }),
+
+ GUI => Fcm::CLI::Subcommand->new({
+ names => ['gui'],
+ synopsis => 'invokes the GUI wrapper for code management commands',
+ usage => '[PATH]',
+ description => $DESCRIPTION_OF{GUI},
+ invoker_class => 'Fcm::CLI::Invoker::GUI',
+ }),
+
+ HELP => Fcm::CLI::Subcommand->new({
+ names => ['help', q{?}, q{}],
+ synopsis => 'displays the usage of this program or its subcommands',
+ usage => '[SUBCOMMAND]',
+ description => q{},
+ invoker_class => 'Fcm::CLI::Invoker::Help',
+ options => [$OPTION_OF{HELP}],
+ }),
+
+ KEYWORD => Fcm::CLI::Subcommand->new({
+ names => ['keyword-print', 'kp'],
+ synopsis => 'prints registered location and/or revision keywords',
+ usage => '[TARGET]',
+ description => $DESCRIPTION_OF{KEYWORD},
+ invoker_class => 'Fcm::CLI::Invoker::KeywordPrinter',
+ options => [$OPTION_OF{HELP}],
+ }),
+
+ MKPATCH => Fcm::CLI::Subcommand->new({
+ names => ['mkpatch'],
+ synopsis => 'creates patches from specified revisions of a URL',
+ usage => '[OPTIONS] URL [OUTDIR]',
+ invoker_class => 'Fcm::CLI::Invoker::CM',
+ is_vc => 1,
+ }),
+);
+
+our @CORE_SUBCOMMANDS = (
+ $SUBCOMMAND_OF{HELP},
+ $SUBCOMMAND_OF{BUILD},
+ $SUBCOMMAND_OF{CFG_PRINTER},
+);
+
+our @VC_SUBCOMMANDS = (
+ $SUBCOMMAND_OF{BRANCH},
+ $SUBCOMMAND_OF{BROWSER},
+ $SUBCOMMAND_OF{CONFLICTS},
+ $SUBCOMMAND_OF{EXTRACT},
+ $SUBCOMMAND_OF{EXTRACT_CONFIG_COMPARATOR},
+ $SUBCOMMAND_OF{GUI},
+ $SUBCOMMAND_OF{KEYWORD},
+ $SUBCOMMAND_OF{MKPATCH},
+ $SUBCOMMAND_OF{CM},
+);
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Config::Default
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Config::Default;
+ @core_subcommands = @Fcm::CLI::Config::Default::CORE_SUBCOMMANDS;
+ @vc_subcommands = @Fcm::CLI::Config::Default::VC_SUBCOMMANDS;
+
+=head1 DESCRIPTION
+
+This module stores the default configuration of the FCM command line interface.
+It should only be used by L.
+
+=head1 SEE ALSO
+
+L,
+L,
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Exception.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Exception.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Exception.pm (revision 9596)
@@ -0,0 +1,42 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Exception;
+use base qw{Fcm::Exception};
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Exception
+
+=head1 SYNOPSIS
+
+ use Carp qw{croak};
+ use Fcm::CLI::Exception;
+ croak(Fcm::CLI::Exception->new({message => 'something is wrong'}));
+
+=head1 DESCRIPTION
+
+This class extends L. This exception is thrown
+on errors associated with the command line interface.
+
+=head1 METHODS
+
+See L for a list of methods.
+
+=head1 SEE ALSO
+
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker.pm (revision 9596)
@@ -0,0 +1,136 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Invoker;
+
+use Carp qw{croak};
+use Fcm::CLI::Exception;
+
+################################################################################
+# Constructor
+sub new {
+ my ($class, $args_ref) = @_;
+ return bless({%{$args_ref}}, $class);
+}
+
+################################################################################
+# Returns the name of the (sub)command as given by the user
+sub get_command {
+ my ($self) = @_;
+ return $self->{command};
+}
+
+################################################################################
+# Returns a reference to a hash containing the options
+sub get_options {
+ my ($self) = @_;
+ return (wantarray() ? %{$self->{options}} : $self->{options});
+}
+
+################################################################################
+# Returns a reference to an array containing the arguments
+sub get_arguments {
+ my ($self) = @_;
+ return (wantarray() ? @{$self->{arguments}} : $self->{arguments});
+}
+
+################################################################################
+# Invokes the sub-system
+sub invoke {
+ my ($self) = @_;
+ my $message = "command not implemented\n";
+ $message .= sprintf("opts:");
+ for my $key (sort keys(%{$self->get_options()})) {
+ my $value = $self->get_options()->{$key};
+ $message .= sprintf(
+ " [%s=%s]",
+ $key,
+ ($value && ref($value) eq 'ARRAY' ? join(q{, }, @{$value}) : $value)
+ );
+ }
+ $message .= sprintf("\n");
+ $message .= sprintf("args: [%s]\n", join(q{] [}, $self->get_arguments()));
+ croak(Fcm::CLI::Exception->new({message => $message}));
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Invoker
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Invoker;
+ $invoker = Fcm::CLI::Invoker->new({
+ command => $command,
+ options => \%options,
+ arguments => $arguments,
+ });
+ $invoker->invoke();
+
+=head1 DESCRIPTION
+
+This is the base class for an invoker of a FCM sub-system from the CLI.
+Sub-classes should override the invoke() method.
+
+=head1 METHODS
+
+=over 4
+
+=item new($args_ref)
+
+Constructor. It accepts a hash reference as an argument. The element I
+should be set to the actual (sub)command as specified by the user. The element
+I should be a reference to a hash containing the specified command line
+options. The element I should be a reference to an array containing
+the remaining command line arguments.
+
+=item get_command()
+
+Returns the actual (sub)command as specified by the user.
+
+=item get_options()
+
+Returns a hash containing the specified command line options. In scalar context,
+returns a reference to the hash.
+
+=item get_arguments()
+
+Returns an array containing the (remaining) command line arguments. In scalar
+context, returns a reference to the array.
+
+=item invoke()
+
+Sub-classes should override this method. Calling the method in this base
+class causes the system to croak() with a
+L.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item L
+
+The C croak() with this exception.
+
+=back
+
+=head1 SEE ALSO
+
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm (revision 9596)
@@ -0,0 +1,119 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Invoker::Browser;
+use base qw{Fcm::CLI::Invoker};
+
+use Carp qw{croak};
+use Fcm::CLI::Exception;
+use Fcm::Config;
+use Fcm::Keyword;
+use Fcm::Util qw{expand_tilde get_url_of_wc is_wc run_command};
+
+################################################################################
+# Invokes the sub-system
+sub invoke {
+ my ($self) = @_;
+ my $config = Fcm::Config->instance();
+ my $browser
+ = $self->get_options()->{browser} ? $self->get_options()->{browser}
+ : $config->setting(qw/WEB_BROWSER/)
+ ;
+ my ($target) = $self->get_arguments();
+ if (!$target) {
+ if (is_wc()) {
+ $target = q{.};
+ }
+ else {
+ croak(Fcm::CLI::Exception->new({
+ message => 'no TARGET specified and . not a working copy',
+ }));
+ }
+ }
+ $target = expand_tilde($target);
+ if (-e $target) {
+ $target = get_url_of_wc($target);
+ }
+
+ my $browser_url = Fcm::Keyword::get_browser_url($target);
+ my @command = (split(qr{\s+}xms, $browser), $browser_url);
+ run_command(\@command, METHOD => 'exec', PRINT => 1);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Invoker::Browser
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Invoker::Browser;
+ $invoker = Fcm::CLI::Invoker::Browser->new({
+ command => $command,
+ options => \%options,
+ arguments => $arguments,
+ });
+ $invoker->invoke();
+
+=head1 DESCRIPTION
+
+This class extends L an inherits all its
+methods. An object of this class is used to invoke a web browser of a VC
+location.
+
+=head1 METHODS
+
+See L for a list of inherited methods.
+
+=over 4
+
+=item invoke()
+
+Invokes a web browser for a VC target, if it can be mapped to a browser URL. If
+a target is not specified in arguments, it uses the current working directory
+as the target.
+
+If the browser option is set, it is used as the browser command. Otherwise, the
+default browser is used.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item L
+
+The invoke() method can croak() with this exception if no target is specified
+and a target cannot be deduced from the current working directory.
+
+=item L
+
+The invoke() method can croak() with this exception if the target cannot be
+mapped to a browser URL.
+
+=back
+
+=head1 TO DO
+
+Unit tests.
+
+=head1 SEE ALSO
+
+L,
+L,
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm (revision 9596)
@@ -0,0 +1,69 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Invoker::CM;
+use base qw{Fcm::CLI::Invoker};
+
+use Fcm::Cm qw{cli};
+
+################################################################################
+# Invokes the sub-system
+sub invoke {
+ my ($self) = @_;
+ return cli($self->get_command(), @ARGV);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Invoker::CM
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Invoker::CM;
+ $invoker = Fcm::CLI::Invoker::CM->new();
+ $invoker->invoke();
+
+=head1 DESCRIPTION
+
+This class extends L an inherits all its
+methods. An object of this class is used to invoke a command in the CM
+sub-system.
+
+It is worth noting that this is not yet a full implementation.
+
+=head1 METHODS
+
+See L for a list of inherited methods.
+
+=over 4
+
+=item invoke()
+
+Invokes a command in the CM sub-system.
+
+=back
+
+=head1 TO DO
+
+Bring the CM system into this framework.
+
+Unit tests.
+
+=head1 SEE ALSO
+
+L,
+L
+
+=head1 COPYRIGHT
+
+E<169> Crown copyright Met Office. All rights reserved.
+
+=cut
Index: NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm
===================================================================
--- NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm (revision 9596)
+++ NEMO/trunk/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm (revision 9596)
@@ -0,0 +1,105 @@
+# ------------------------------------------------------------------------------
+# (C) Crown copyright Met Office. All rights reserved.
+# For further details please refer to the file COPYRIGHT.txt
+# which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+use strict;
+use warnings;
+
+package Fcm::CLI::Invoker::CfgPrinter;
+use base qw{Fcm::CLI::Invoker};
+
+use Carp qw{croak};
+use Fcm::Exception;
+use Fcm::CfgFile;
+use Fcm::Config;
+
+################################################################################
+# Invokes the sub-system
+sub invoke {
+ my ($self) = @_;
+ my ($cfg_file) = $self->get_arguments();
+ if (!$cfg_file) {
+ croak(Fcm::CLI::Exception->new({message => 'no CFGFILE specified'}));
+ }
+ my $cfg = Fcm::CfgFile->new(SRC => $cfg_file);
+ Fcm::Config->instance()->verbose(0); # suppress message printing to STDOUT
+ my $read = $cfg->read_cfg();
+ if (!$read) {
+ croak(Fcm::Exception->new({message => sprintf(
+ "% :cannot read", $cfg_file,
+ )}));
+ }
+ $cfg->print_cfg($self->get_options()->{output});
+ }
+
+1;
+__END__
+
+=head1 NAME
+
+Fcm::CLI::Invoker::CfgPrinter
+
+=head1 SYNOPSIS
+
+ use Fcm::CLI::Invoker::CfgPrinter;
+ $invoker = Fcm::CLI::Invoker::CfgPrinter->new({
+ command => $command,
+ options => \%options,
+ arguments => $arguments,
+ });
+ $invoker->invoke();
+
+=head1 DESCRIPTION
+
+This class extends L an inherits all its
+methods. An object of this class is used to invoke the pretty printer for FCM
+configuration files.
+
+=head1 METHODS
+
+See L for a list of inherited methods.
+
+=over 4
+
+=item invoke()
+
+Invokes the pretty printer for a FCM configuration file.
+
+If the I