#!/usr/bin/perl -w ######################################################################## # Create a makefile and optionally compile the fortran program file(s) # provided on the command line. # Each file is scanned for dependencies and all dependencies are # compiled and linked to the main program. # # Larry Solheim ...Jun 5,2013 ######################################################################## use strict; use File::Basename; use Cwd qw(cwd abs_path); use Data::Dumper; use Storable qw(nstore_fd fd_retrieve); # Storeable hashes will have elements sorted on keys $Storable::canonical = 1; # Declare global variables use vars qw( $verbose $DBG %usrvar @suffix_list $Runame $make_include_file %with %set_by_usr $cmd_line $CCRNSRC @path_list_all %undefs @DEP_list $usr_FC $usr_FFLAGS $usr_LIBS $usr_INCS $ocn_src_repo $updates_file $cppdefs_file $cppdefs_diag $sizes_file %parmsub $proj_lib %compile_file @main_targets %main_target_name $ocndir $stamp $ocn_user_source $ocn_use_cpp $atmver $modver $ocnver $main_count $cancpl_ver $cancpl_repo %exclude_dir %exclude_file @up2patch_flist %vardim @veryclean_flist $parmsub_file $COUPLER_COMMIT $COUPLER_REPO $cccmf_clones_cpl @path_list_dk $mach_type ); use vars qw( %source %full_path %is_main %is_target %usr_target %contains_mod %uses_mod %scanned_this_file %has_cppdefs %has_ddelim %in_lib %proj_member); use vars qw( $FIXED_format $default_FIXED_format $allow_set_format %freefmt ); # These hashes identify the files in which particular functions, subroutines, # and modules may be found use vars qw( %func_path %mod_path %sub_path %com_path %generic_procedure %obj_path %obj_file ); # These dup_... hashes are currently not used but may be in the future use vars qw( %dup_func_path %dup_mod_path %dup_sub_path %dup_generic_procedure ); # These hashes are created in find_depends use vars qw( %inc_depends %mod_depends %all_depends %not_found %scanned_by_find_dep ); use vars qw( %child_of %parent_of ); my $VERSION = "0.01"; chomp(my $Runame = `basename $0`); use Sys::Hostname; my $host = hostname(); $host =~ s/^(.*?)\..*$/$1/; # Build component switches my $build_agcm = "0"; my $build_coupler = "0"; $build_agcm = $ENV{build_agcm}; $build_coupler = $ENV{build_coupler}; print "build_agcm = $build_agcm\n"; print "build_coupler = $build_coupler\n"; # Define a local variable to indicate the root dir of the CCRN source tree my $CCRNSRC = ""; if ( $ENV{CCRNSRC} ) { # Define CCRNSRC if it is defined in the current environment # The official UVic CCRNSRC source tree is out of date # However, a subdir named $CCRNSRC/sv08src does contain regularly updated source # This dir only exists at UVic so it should be safe to use it if it exists if ( -d "$ENV{CCRNSRC}/sv08src" ) { $CCRNSRC = "$ENV{CCRNSRC}/sv08src"; } elsif ( -d "$ENV{CCRNSRC}" ) { $CCRNSRC = "$ENV{CCRNSRC}"; } else { die "CCRNSRC=$ENV{CCRNSRC} is not a directory\n"; } # Follow any links $CCRNSRC = readlink $CCRNSRC if -l $CCRNSRC; # Ensure this is an absolute pathname $CCRNSRC = abs_path( $CCRNSRC ); } # ocn_src_repo points to the git repository that contains ocean source code my $ocn_src_repo = ""; $ocn_src_repo = "$ENV{CCRNSRC}/ocean_dir/ocn-mirror.git" if $ENV{CCRNSRC}; # Define a default fixed format $default_FIXED_format = 1; # Define an alias for the current host and determine kernel type # Optionally define a prefix for all ssh commands # to reroute through a head node when required my $mach_name = ""; my $mach_type = ""; my $ROUTE_SSH = ""; # $MAKE is the invocation name for make when this script runs make # (ie when --x is supplied by the user on the command line) my $MAKE = $ENV{MAKE} ? $ENV{MAKE} : "make"; if ($host =~ /^lx/) { # Assume this is a machine in Victoria $mach_name = $host; $mach_type = "linux"; $ocn_src_repo = "/home/rls/src/ocean"; } elsif ( $host =~ /^joule/ ) { $mach_name = "joule"; $mach_type = "linux"; } elsif ( $host =~ /^ib3/ ) { $mach_name = "pollux"; $mach_type = "linux"; $ROUTE_SSH = "ssh pollux"; } elsif ( $host =~ /^ib8/ ) { $mach_name = "mez"; $mach_type = "linux"; $ROUTE_SSH = "ssh mez"; } elsif ( $host =~ /^c1/ ) { $mach_name = "spica"; $mach_type = "aix"; $ROUTE_SSH = "ssh spica"; $MAKE = "/usr/bin/gmake" unless $ENV{MAKE}; } elsif ( $host =~ /^c2/ ) { $mach_name = "hadar"; $mach_type = "aix"; $ROUTE_SSH = "ssh hadar"; $MAKE = "/usr/bin/gmake" unless $ENV{MAKE}; } elsif ( $host =~ /^xc1/ ) { $mach_name = "hare"; $mach_type = "linux"; } elsif ( $host =~ /^xc2/ ) { $mach_name = "brooks"; $mach_type = "linux"; } elsif ( $host =~ /^xc3/ ) { $mach_name = "banting"; $mach_type = "linux"; } elsif ( $host =~ /^xc4/ ) { $mach_name = "daley"; $mach_type = "linux"; } else { die "** EE ** Unrecognized host $host\n"; } # define a unique stamp for file name id etc chomp(my $stamp = `date "+%Y%j"$$`); my $cmd_line = ""; foreach (@ARGV) { if (/=/) { my ($var,$val) = /^\s*(.*?)=(.*)/; if ( $val =~ / / ) { # Quote values that contain spaces $cmd_line .= $cmd_line ? " $var=\"$val\"" : "$var=\"$val\""; } else { $cmd_line .= $cmd_line ? " $_" : $_; } } else { $cmd_line .= $cmd_line ? " $_" : $_; } } # User definable parameters # Set default verbosity level (a larger value means more output) my $verbose = 0; # Flag debug mode (use -debug on command line to activate) my $DBG = 0; # force_free_format is a boolean flag to indicate to fordep that the input # file contains free format fortran source. Normally fordep will figure this # out and so this should rarely be required. # Note that using a file name suffix of ".f90" or ".F90" has the same effect my $force_free_format = 0; # The name of a user supplied file containing additional commands, # macro defs etc, to be included in the makefile created below my $make_include_file = ""; # The name of the makefile that will be created below my $make_file_name = "makefile_cccmf.mk"; # A boolean flag to indicate that a list of dependent source files is to be # written to stdout and then the program will stop my $list_only = 0; # The name of a file to contain a list of dependencies # If defined this file will be created rather than a makefile my $depends_file = ""; # Show dependent source files that live below $CCRNSRC/source # $depends_ccrnsrc == 1 ...show all dependent files below $CCRNSRC/source # $depends_ccrnsrc == 2 ...show all dependent files below $CCRNSRC/source/lsmod # $depends_ccrnsrc == 3 ...show all dependent files below $CCRNSRC/source/lssub my $depends_ccrnsrc = 0; # main_count is a counter to keep track of the number of "main" targets that # are added tothe output make file my $main_count = 0; # User supplied values for FC and FFLAGS, supplied on the commmand line # This is an alternative to setting FC and FFLAGS via the make include file my $usr_FC = ""; my $usr_FFLAGS = ""; my $usr_LIBS = ""; my $usr_INCS = ""; # with{netcdf} is a boolean flag used to determine if netcdf library paths # and includes will be added to the output makefile $with{netcdf} = 0; # with{omp} is a boolean flag used to determine if a compiler command line # suitable for using OpenMP will be added to the output makefile $with{omp} = 0; # with{mpi} is a boolean flag used to determine if a compiler command line # suitable for using MPI will be added to the output makefile $with{mpi} = 0; # with{coupled} is a boolean flag used to determine if a makefile suitable # for compiling the coupled model will be created $with{coupled} = 0; # Set defaults for the use of "float1" and "float2" compiler lines $with{float1} = 0; $with{float2} = 1; # Use, or not use certain libraries from the power5 on the power7 $with{p5lib} = 0; # This may be used to identify the variant of a compiled library to be used # If this is false then "noxlfqinitauto" will be added to the library name # This also determines whether or not the -qinitauto=7FF7FFFF command line # option will be filtered from the xlf command # This option is removed if $with{xlfqinitauto} is false # Connected to the noxlfqinitauto parmsub parameter $with{xlfqinitauto} = 1; # Determine whether or not the -qflttrap=imprecise should be filtered from the # xlf command line (only meaninful when using the xlf compiler) # This option is removed if $with{xlfimp} is false # Connected to the noxlfimp parmsub parameter $with{xlfimp} = 1; # This may be used to identify the variant of a compiled library to be used # If this is set then its value will be added to the library name # Connected to one of the parmsub parameters: xlf12104, xlf13108, xlf14101 $with{xlfversion} = ""; # When true , extra options will be added to the xlf command line, namely # -bdatapsize:64K -bstackpsize:64K -btextpsize:64K # These options set page size to 64K $with{xlflarge} = 1; # atmver|modver are used to extract version dependent subdirs from the CCRNSRC source tree # Typical values are gcm13e, gcm15d, gcm16, gcm17, ... my $atmver = ""; my $modver = ""; my $GIT = "git"; my $cancpl_ver = ""; my $cancpl_repo = ""; my $cccmf_clones_cpl = 0; my $run_up2patch = 1; # ocnver is used to extract a particular version of the ocean code from a repository my $ocnver = ""; # If ocean code is extracted then it will be placed in the ocndir directory my $ocndir = "local_ocnsrc"; # If defined this will be the name of a directory containing user supplied # ocean source code which will overwrite any ocean source files of the same # name that are found in the ocean source repository my $ocn_user_source = ""; # Preprocess ocean source files using the system cpp processor rather than # the fortran preprocessor # This may be required if the ocean source if from CanESM4.1 or earlier and # has not been filtered to remove c-style comments and cpp continuation # lines from all cpp directives found in these source files # Note that this filtering is done below so this should only be needed if the # user supplied some bad code (unfiltered when it should have been filtered) my $ocn_use_cpp = 0; # The name of a file that will be used to cache dependency info # A default name is defined below if the user does not supply one my $atm_cache_file = ""; # Set a boolean flag used to determine if the cache file will be overwritten # regardless of any other criteria, such as modification time my $create_atm_cache = 0; # Boolean flag to indicate that the info stored in the cache file should # be printed to stdout, then the program should exit my $print_cache_info = 0; # The name of a file containing all variable definitions found in the parmsub # section of a user supplied file containing a model job string # if parmsub_file is defined on the command line then cccmf will create this # file and then exit without any further processing. # The result is that the parmsub file is the only file created by cccmf. my $parmsub_file = ""; # updates_file is the name of a file containing model or sub updates # These updates will be applied and the modified files will be placed in # the current working dir to be used by the make file my $updates_file = ""; # cppdefs_file is the name of a file containing cpp defines, directives etc that # will be prepended to or included with all files that require preprocessing, # prior to compilation (e.g. files with a .F, .F90, .F95 suffix) my $cppdefs_file = ""; # cppdefs_diag is the name of a file containing cpp defines, directives etc that # will be prepended to or included with all files that require preprocessing, # prior to compilation (e.g. files with a .F, .F90, .F95 suffix) my $cppdefs_diag = ""; # sizes_file is the name of a text file containing replacement values # for "$" delimited variables that may appear in some source files my $sizes_file = ""; # A flag to determine if this program should run the make file once it has been created my $run_make = 0; # The name of a local project library that is created by the make file my $proj_lib = "proj"; # Define a global hash (%vardim) containing replacement values for $...$ delimited # strings that are found in CCCma variable dimension fortran source files def_var_dim_par(); # Local variables my ( $help, @NonOpt, @flist ); # Allowed fortran file name suffixes my @suffix_list = ( q(\.f), q(\.F), q(\.f90), q(\.f95), q(\.F90), q(\.F95), q(\.dk), q(\.cdk), q(\.h), q(\.inc), q(\.vd) ); # The set of command line parameters that may be set by the user # These are all the keys that are allowed in %usrvar my @cmdl_params = ( "verbose", "make_inc", "path", "path_list", "pathdk", "pathdk_list", "atmver", "modver", "cache", "cache_only", "FC", "FFLAGS", "ocnver", "ocndir", "updates", "cppdefs", "cppdefs_diag", "sizes", "make_file", "model_job", "xlfversion", "LIBS", "INCS", "target", "user_source", "exclude", "flist", "proj_lib", "depends_file", "cancpl_ver", "cancpl_repo", "parmsub_file", "prgenv" ); # If there were no commnad line args then print usage info and exit usage(0) if scalar(@ARGV)<1; # Process command line arguments # The set_by_usr hash is "true" when the parameter name (hash key) has been # defined by the user either from the command line (in which case the value is 1) # or from a file (in which case the value is 2) use Getopt::Long; $Getopt::Long::ignorecase = 0; $Getopt::Long::order = $PERMUTE; &GetOptions("verbose" => sub {$verbose++}, "help!" => \$help, "x!" => \$run_make, "up2patch!" => \$run_up2patch, "list_only!" => \$list_only, "depends_ccrnsrc!" => sub {$depends_ccrnsrc = 1}, "depends_lsmod!" => sub {$depends_ccrnsrc = 2}, "depends_lssub!" => sub {$depends_ccrnsrc = 3}, "wcache!" => sub {$create_atm_cache=$_[1]; $set_by_usr{create_atm_cache}=1}, "pcache!" => sub {$print_cache_info=$_[1]; $set_by_usr{print_cache_info}=1}, "netcdf!" => sub {$with{netcdf}=$_[1]; $set_by_usr{netcdf}=1}, "omp!" => sub {$with{omp}=$_[1]; $set_by_usr{omp}=1}, "mpi!" => sub {$with{mpi}=$_[1]; $set_by_usr{mpi}=1}, "coupled!" => sub {$with{coupled}=$_[1]; $set_by_usr{coupled}=1}, "float1!" => sub {$with{float1}=$_[1]; $with{float2}=$with{float1} ? 0 : 1; $set_by_usr{float1}=1}, "float2!" => sub {$with{float2}=$_[1]; $with{float1}=$with{float2} ? 0 : 1; $set_by_usr{float2}=1}, "xlfqinitauto!" => sub {$with{xlfqinitauto}=$_[1]; $set_by_usr{xlfqinitauto}=1}, "xlfimp!" => sub {$with{xlfimp}=$_[1]; $set_by_usr{xlfimp}=1}, "xlflarge!" => sub {$with{xlflarge}=$_[1]; $set_by_usr{xlflarge}=1}, "p5lib!" => sub {$with{p5lib}=$_[1]; $set_by_usr{p5lib}=1}, "ocn_use_cpp!" => sub {$with{ocn_use_cpp}=$_[1]; $set_by_usr{ocn_use_cpp}=1}, "<>" => sub {push @NonOpt,$_[0]}) or usage(1); usage(0) if $help; # Process non option command line args foreach (@NonOpt) { next unless $_; if (/=/) { # This is a variable assignment of the form "var=val" # Strip quotes, if any and assign $var and $val s/^\s*"(.*)"\s*$/$1/; s/^\s*'(.*)'\s*$/$1/; my ($var,$val) = /^\s*(.*?)=(.*)/; # Strip leading or trailing whitespace from the value $val =~ s/^\s*(.*?)\s*$/$1/; # Strip quotes from the value, if any $val =~ s/^\s*"(.*)"\s*$/$1/; $val =~ s/^\s*'(.*)'\s*$/$1/; # Require a non NULL value unless ( $val eq "0" ) { die "Missing value for $_\n" unless $val; } # Check for valid parameter names my $found = 0; foreach my $parm (@cmdl_params) { if ( $parm eq $var ) { $found = 1; last; } } unless ($found) { usage(1,"Invalid command line parameter --> $var <--"); } # Add variable defs found on the command line to the usrvar hash if ( $var eq "comment" or $var eq "sentence" ) { # Treat these variable values as a single string, allowing white space within # There will be only one value allowed for this variable which will be # overwritten by subsequent defs for the same variable $usrvar{$var} = $val; } else { # Multiple variable assignments for the same variable will be added to a # list of values for that variable. # Each individual assignment will be split on whitespace and added # as a separate entry in the list of values. $val =~ s/^\s*(.*?)\s*$/$1/; push @{$usrvar{$var}}, split(/\s+/,$val); } next; } # Any remaining command line arg should be program file names push @flist, $_; } # If the user supplied a file containing a list of file names to process # then read them now and append any files found therein to @flist if ( $usrvar{flist} ) { # Only the first element of this array is significant, all others are ignored my $flist_file = @{$usrvar{flist}}[0]; if ( scalar(@{$usrvar{flist}})>1 ) { warn "Multiple values for flist found on command line. --> @{$usrvar{flist}} <--\n"; warn "Using flist = $flist_file\n"; } open(FLIST, "<$flist_file") or die "Unable to open $flist_file $!\n"; while () { chomp($_); next if /^\s*#/; next if /^\s*$/; # Use only the first whitespace separated word found on this line push @flist, (split(" ",$_))[0]; } close(FLIST); } # Set parmsub_file from a command line definition if ( $usrvar{parmsub_file} ) { # Only the first element of this array is significant, all others are ignored $parmsub_file = @{$usrvar{parmsub_file}}[0]; if ( scalar(@{$usrvar{parmsub_file}})>1 ) { warn "Multiple values for parmsub_file found on command line. --> @{$usrvar{parmsub_file}} <--\n"; warn "Using parmsub_file = $parmsub_file\n"; } # Also assign set_by_usr for use below $set_by_usr{parmsub_file} = 1; } # Set prgenv from a command line definition if ( $usrvar{prgenv} ) { # Also assign set_by_usr for use below $set_by_usr{prgenv} = 1; } unless ( $usrvar{cache_only} or $print_cache_info or $set_by_usr{parmsub_file} ) { # Do not make this check when the user has defined cache_only on the command line # or supplied the --pcache option on the command line usage(1,"At least one file name is required on the command line.") unless (scalar(@flist)); } # Save the name of the current working directory for use below my $CWD = cwd(); die "Unable to determine current working directory\n" unless -d $CWD; if ($verbose > 10) { foreach (sort keys %usrvar) { print "found on cmdline: $_ = ",join(",",@{$usrvar{$_}}),"\n"; } } # Set verbose from a command line definition if ( $usrvar{verbose} ) { # Only the first element of this array is significant, all others are ignored $verbose = @{$usrvar{verbose}}[0]; if ( scalar(@{$usrvar{verbose}})>1 ) { warn "Multiple values for verbose found on command line. --> @{$usrvar{verbose}} <--\n"; warn "Using verbose = $verbose\n"; } die "verbose must be an integer.\n" unless $verbose =~/^\s*\d+\s*$/; } # Reset verbose when no extra output is desired $verbose = -1 if $list_only; $verbose = -1 if $depends_ccrnsrc; # Set atmver from a command line definition if ( $usrvar{atmver} ) { # If the user has specified atmver on the command line then CCRNSRC must also # be defined in the users environment die "atmver was supplied on the command line but CCRNSRC is not defined in this environment.\n" unless $CCRNSRC; # Only the first element of this array is significant, all others are ignored $atmver = @{$usrvar{atmver}}[0]; if ( scalar(@{$usrvar{atmver}})>1 ) { warn "Multiple values for atmver found on command line. --> @{$usrvar{atmver}} <--\n"; warn "Using atmver = $atmver\n"; } # Ensure atmver and modver are identical $modver = $atmver; # Ensure the corresponding lsmod dir exists if ( $verbose > 2 ) { unless ( -d "$CCRNSRC/source/lsmod/agcm/$modver" ) { warn "** WW ** atmver = $atmver but $CCRNSRC/source/lsmod/agcm/$modver is not a directory\n" } } # Also assign set_by_usr for use below $set_by_usr{atmver} = 1; $set_by_usr{modver} = 1; } # Set modver from a command line definition if ( $usrvar{modver} ) { # If the user has specified modver on the command line then CCRNSRC must also # be defined in the users environment die "modver was supplied on the command line but CCRNSRC is not defined in this environment.\n" unless $CCRNSRC; # Only the first element of this array is significant, all others are ignored $modver = @{$usrvar{modver}}[0]; if ( scalar(@{$usrvar{modver}})>1 ) { warn "Multiple values for modver found on command line. --> @{$usrvar{modver}} <--\n"; warn "Using modver = $modver\n"; } # Ensure atmver and modver are identical $atmver = $modver; # Ensure the corresponding lsmod dir exists if ( $verbose > 2 ) { unless ( -d "$CCRNSRC/source/lsmod/agcm/$modver" ) { warn "** WW ** modver = $modver but $CCRNSRC/source/lsmod/agcm/$modver is not a directory\n" } } # Also assign set_by_usr for use below $set_by_usr{atmver} = 1; $set_by_usr{modver} = 1; } # Set cancpl_repo from a command line definition if ( $usrvar{cancpl_repo} ) { # Only the first element of this array is significant, all others are ignored $cancpl_repo = @{$usrvar{cancpl_repo}}[0]; if ( scalar(@{$usrvar{cancpl_repo}})>1 ) { warn "Multiple values for cancpl_repo found on command line. --> @{$usrvar{cancpl_repo}} <--\n"; warn "Using cancpl_repo = $cancpl_repo\n"; } # Also assign set_by_usr for use below $set_by_usr{cancpl_repo} = 1; } # Set cancpl_ver from a command line definition if ( $usrvar{cancpl_ver} ) { # Only the first element of this array is significant, all others are ignored $cancpl_ver = @{$usrvar{cancpl_ver}}[0]; if ( scalar(@{$usrvar{cancpl_ver}})>1 ) { warn "Multiple values for cancpl_ver found on command line. --> @{$usrvar{cancpl_ver}} <--\n"; warn "Using cancpl_ver = $cancpl_ver\n"; } # Also assign set_by_usr for use below $set_by_usr{cancpl_ver} = 1; } # Set ocnver from a command line definition if ( $usrvar{ocnver} ) { # Only the first element of this array is significant, all others are ignored $ocnver = @{$usrvar{ocnver}}[0]; if ( scalar(@{$usrvar{ocnver}})>1 ) { warn "Multiple values for ocnver found on command line. --> @{$usrvar{ocnver}} <--\n"; warn "Using ocnver = $ocnver\n"; } # Also assign set_by_usr for use below $set_by_usr{ocnver} = 1; # Verify that this is a valid tag my @sh_out = syscmd( "cd $ocn_src_repo; $GIT tag" ); my $found = 0; foreach (@sh_out) { if ( $ocnver eq "$_" ) { $found = 1; last; } } unless ( $found ) { warn "** EE ** Invalid ocnver = $ocnver\n"; print "Valid values for ocean model version are:\n"; foreach (@sh_out) {print "\t$_\n" unless /^nemo/i} die "\n"; } } # Set the name of the project library to be created by the make file if ( $usrvar{proj_lib} ) { # Only the first element of this array is significant, all others are ignored $proj_lib = @{$usrvar{proj_lib}}[0]; if ( scalar(@{$usrvar{proj_lib}})>1 ) { warn "Multiple values for proj_lib found on command line. --> @{$usrvar{proj_lib}} <--\n"; warn "Using proj_lib = $proj_lib\n"; } # Also assign set_by_usr for use below $set_by_usr{proj_lib} = 1; } # Set user_source from a command line definition if ( $usrvar{user_source} ) { # Only the first element of this array is significant, all others are ignored $ocn_user_source = @{$usrvar{user_source}}[0]; if ( scalar(@{$usrvar{user_source}})>1 ) { warn "Multiple values for user_source found on command line. --> @{$usrvar{user_source}} <--\n"; warn "Using user_source = $ocn_user_source\n"; } # Also assign set_by_usr for use below $set_by_usr{user_source} = 1; } # Set the name of a tmp dir used to hold ocean source from a command line definition if ( $usrvar{ocndir} ) { # Only the first element of this array is significant, all others are ignored $ocndir = @{$usrvar{ocndir}}[0]; if ( scalar(@{$usrvar{ocndir}})>1 ) { warn "Multiple values for ocndir found on command line. --> @{$usrvar{ocndir}} <--\n"; warn "Using ocndir = $ocndir\n"; } # Also assign set_by_usr for use below $set_by_usr{ocndir} = 1; } # Set the name of a dependency to be created if ( $usrvar{depends_file} ) { # Only the first element of this array is significant, all others are ignored $depends_file = @{$usrvar{depends_file}}[0]; if ( scalar(@{$usrvar{depends_file}})>1 ) { warn "Multiple values for depends_file found on command line. --> @{$usrvar{depends_file}} <--\n"; warn "Using depends_file = $depends_file\n"; } # Also assign set_by_usr for use below $set_by_usr{depends_file} = 1; } # Set the name of a user supplied make include file from a command line definition if ( $usrvar{make_inc} ) { # Only the first element of this array is significant, all others are ignored $make_include_file = @{$usrvar{make_inc}}[0]; if ( scalar(@{$usrvar{make_inc}})>1 ) { warn "Multiple values for make_inc found on command line. --> @{$usrvar{make_inc}} <--\n"; warn "Using make_inc = $make_include_file\n"; } die "make include file ",$make_include_file," is missing or empty\n" unless -s $make_include_file; } # Set a user supplied make file name if ( $usrvar{make_file} ) { # Only the first element of this array is significant, all others are ignored $make_file_name = @{$usrvar{make_file}}[0]; if ( scalar(@{$usrvar{make_file}})>1 ) { warn "Multiple values for make_file found on command line. --> @{$usrvar{make_file}} <--\n"; warn "Using make_file = $make_file_name\n"; } } # Set the name of a user supplied file containing model updates if ( $usrvar{updates} ) { # Only the first element of this array is significant, all others are ignored $updates_file = @{$usrvar{updates}}[0]; if ( scalar(@{$usrvar{updates}})>1 ) { warn "Multiple values for updates found on command line. --> @{$usrvar{updates}} <--\n"; warn "Using updates = $updates_file\n"; } die "updates file ",$updates_file," is missing or empty\n" unless -s $updates_file; # Also assign set_by_usr for use below $set_by_usr{updates} = 1; } # Set the name of a user supplied file containing cpp defines if ( $usrvar{cppdefs} ) { # Only the first element of this array is significant, all others are ignored $cppdefs_file = @{$usrvar{cppdefs}}[0]; if ( scalar(@{$usrvar{cppdefs}})>1 ) { warn "Multiple values for cppdefs found on command line. --> @{$usrvar{cppdefs}} <--\n"; warn "Using cppdefs = $cppdefs_file\n"; } die "cppdefs file ",$cppdefs_file," is missing or empty\n" unless -s $cppdefs_file; # Also assign set_by_usr for use below $set_by_usr{cppdefs} = 1; } # Set the name of a user supplied file containing cpp defines if ( $usrvar{cppdefs_diag} ) { # Only the first element of this array is significant, all others are ignored $cppdefs_diag = @{$usrvar{cppdefs_diag}}[0]; if ( scalar(@{$usrvar{cppdefs_diag}})>1 ) { warn "Multiple values for cppdefs_diag found on command line. --> @{$usrvar{cppdefs_diag}} <--\n"; warn "Using cppdefs_diag = $cppdefs_diag\n"; } die "cppdefs_diag file ",$cppdefs_diag," is missing or empty\n" unless -s $cppdefs_diag; # Also assign set_by_usr for use below $set_by_usr{cppdefs_diag} = 1; } # Set the name of a user supplied file containing replacement values for "$" delimited # strings that may appear in some source code files if ( $usrvar{sizes} ) { # Only the first element of this array is significant, all others are ignored $sizes_file = @{$usrvar{sizes}}[0]; if ( scalar(@{$usrvar{sizes}})>1 ) { warn "Multiple values for sizes found on command line. --> @{$usrvar{sizes}} <--\n"; warn "Using sizes = $sizes_file\n"; } die "sizes file ",$sizes_file," is missing or empty\n" unless -s $sizes_file; # Also assign set_by_usr for use below $set_by_usr{sizes} = 1; } unless ( $usrvar{cache_only} ) { # Do not do this when the user has defined cache_only on the command line # Set the name of a user supplied file containing a model job string my $model_job_file = ""; if ( $usrvar{model_job} ) { # Only the first element of this array is significant, all others are ignored $model_job_file = @{$usrvar{model_job}}[0]; if ( scalar(@{$usrvar{model_job}})>1 ) { warn "Multiple values for model_job found on command line. --> @{$usrvar{model_job}} <--\n"; warn "Using model_job = $model_job_file\n"; } die "model_job file ",$model_job_file," is missing or empty\n" unless -s $model_job_file; # Use info in this file to create updates_file and/or cppdefs_file and/or sizes_file # if they were not specified by the user # This implies that this section of code must always come after that which # defines $updates_file, $cppdefs_file and $sizes_file from command line values # This will also define certain parameter values (if not set explicitly on the command line) # These paramters include: atmver, modver, ocnver model_job_to_cpp_sizes( $model_job_file ); # Also assign set_by_usr for use below $set_by_usr{model_job} = 1; # Assume the use of mpi and openmp when a model string is supplied # The user can override these defaults via --nompi or --noomp command line options $with{mpi} = 1 unless $set_by_usr{mpi}; $with{omp} = 1 unless $set_by_usr{omp}; # Use only system libraries (ie compile all model source) when a model string is supplied # The user can override this default by defining LIBS=... on the command line $usr_LIBS = "system" unless $usrvar{LIBS}; } # At this point we will have a cppdefs_file, if there is one to be had if ( $cppdefs_file ) { die "$cppdefs_file is missing of empty.\n" unless -s $cppdefs_file; # Filter this cppdefs file to remove fortran comments and malformed #undef lines my $CPP_I = ""; open( CPPDEFS, "<$cppdefs_file") or die "$!"; foreach my $line () { # Ignore fortran (fixed format) comments next if $line =~ /^c/i; # Ignore undef lines with more than 1 token following #undef next if $line =~ /^#\s*undef\s+("[\w ]+"|<[\w ]+>|\w+)\s+\w/; $CPP_I .= $line; } close(CPPDEFS); # Rename cppdefs_file to be a temporary file in the cwd and create it chomp( $cppdefs_file = "local_" . `basename $cppdefs_file` ); # substr($cppdefs_file,0,0) = "local_"; open( CPPDEFS, ">$cppdefs_file") or die "$!"; print CPPDEFS $CPP_I; close(CPPDEFS); } # At this point we will have a cppdefs_diag, if there is one to be had if ( $cppdefs_diag ) { die "$cppdefs_diag is missing of empty.\n" unless -s $cppdefs_diag; # Filter this cppdefs file to remove fortran comments and malformed #undef lines my $CPP_I = ""; open( CPPDEFS, "<$cppdefs_diag") or die "$!"; foreach my $line () { # Ignore fortran (fixed format) comments next if $line =~ /^c/i; # Ignore undef lines with more than 1 token following #undef next if $line =~ /^#\s*undef\s+("[\w ]+"|<[\w ]+>|\w+)\s+\w/; $CPP_I .= $line; } close(CPPDEFS); # Rename cppdefs_diag to be a temporary file in the cwd and create it chomp( $cppdefs_diag = "local_" . `basename $cppdefs_diag` ); # substr($cppdefs_diag,0,0) = "local_"; open( CPPDEFS, ">>$cppdefs_file") or die "$!"; print CPPDEFS $CPP_I; close(CPPDEFS); } } # Set the name of the cache file from a command line definition # This needs to be done after atmver is defined which could be # as late as the call to model_job_to_cpp_sizes above if ( $usrvar{cache} ) { # It does not make sense to write an atm cache file unless # atmver was also specified on the command line die "modver must also be defined when cache is defined.\n" unless ($set_by_usr{atmver} or $set_by_usr{modver}); # Only the first element of this array is significant, all others are ignored $atm_cache_file = @{$usrvar{cache}}[0]; if ( scalar(@{$usrvar{cache}})>1 ) { warn "Multiple values for cache found on command line. --> @{$usrvar{cache}} <--\n"; warn "Using cache = $atm_cache_file\n"; } die "cache is not defined.\n" unless $atm_cache_file; $set_by_usr{cache} = 1; } if ( $usrvar{cache_only} ) { # If the model version is supplied on the command line then a cache file # containing version dependent source will be created, otherwise a cache # file containing only common source (independent of the model version) # will be created # Only the first element of this array is significant, all others are ignored $atm_cache_file = @{$usrvar{cache_only}}[0]; if ( scalar(@{$usrvar{cache_only}})>1 ) { warn "Multiple values for cache_only found on command line. --> @{$usrvar{cache_only}} <--\n"; warn "Using cache_only = $atm_cache_file\n"; } die "cache_only is not defined.\n" unless $atm_cache_file; # Determine the cache file name below when the user supplies the name "default" $atm_cache_file = "" if $atm_cache_file eq "default"; $set_by_usr{cache_only} = 1; } unless ( $atm_cache_file ) { # Set a default for atm_cache_file if not set by the user # Use a known system wide location if the file exists # This must be defined relative to the value of CCRNSRC in the current env rather than # the value of CCRNSRC defined in this program (these may differ) if ( $set_by_usr{atmver} or $set_by_usr{modver} ) { # If the user has supplied a model version then use/create a cache file that # contain model version specific code $atm_cache_file = "$ENV{CCRNSRC}/cccjob_dir/cccmake/lib/cache_cccmf_atm_$modver"; # Otherwise create a local cache file $atm_cache_file = ".cache_cccmf_atm_$modver" unless -s $atm_cache_file; } else { # Otherwise use/create a cache file that does not contain model version specific code $atm_cache_file = "$ENV{CCRNSRC}/cccjob_dir/cccmake/lib/cache_cccmf_comm"; # Otherwise create a local cache file $atm_cache_file = ".cache_cccmf_comm" unless -s $atm_cache_file; } } if ( $usrvar{exclude} ) { # Exclude all files or dirs in this list foreach ( @{$usrvar{exclude}} ) { if ( m!/\s*$! ) { # If this ends with a "/" then assume it is a dir # Strip the trailing "/" before defining this hash key my $d = $_; chop($d); $exclude_dir{$d} = 1; } else { # Assume this is a file name my ($name) = fileparse("$_",()); $exclude_file{$name} = 1; } } } # Always ignore certain files in certain model versions # These files will contain duplicate code $exclude_file{"cosp3_fractional_landmask.dk"} = 1 if $atmver eq "gcm16"; $exclude_file{"cosp.dk"} = 1 if $atmver eq "gcm15i"; $exclude_file{"cosp2.dk"} = 1 if $atmver eq "gcm15i"; # model_job_to_cpp_sizes will assign the parmsub global hash and assign, among other things, # a value to $with{coupled} if it has not already been assigned on the command line # It will also update the set_by_usr hash, if appropriate. # Therefore the following check must be done after the call to model_job_to_cpp_sizes if ( $with{coupled} and $cccmf_clones_cpl ) { # The user must supply both atm and coupler code versions since both will need to be compiled my $ok = 0; # if ( $set_by_usr{atmver} and $set_by_usr{ocnver} ) { $ok = 1 } if ( $set_by_usr{cancpl_repo} and $set_by_usr{cancpl_ver} ) { $ok = 1 } unless ( $ok ) { die "When coupled is \"true\" both cancpl_repo and cancpl_ver must be defined.\n"; } } # Set user defined target names from the command line if ( $usrvar{target} ) { # Assign this list to the global main_targets list @main_targets = @{$usrvar{target}}; } # Set the compiler name from the environment if ( $ENV{FC} ) { $usr_FC = $ENV{FC}; # Set usr_LIBS to "none" since we don't know which RTEXTBLS libs to use in this case $usr_LIBS = "none" unless $usr_LIBS; } # Set the compiler name from the command line if ( $usrvar{FC} ) { # Only the first element of this array is significant, all others are ignored $usr_FC = @{$usrvar{FC}}[0]; if ( scalar(@{$usrvar{FC}})>1 ) { warn "Multiple values for FC found on command line. --> @{$usrvar{FC}} <--\n"; warn "Using FC = $usr_FC\n"; } # Set usr_LIBS to "none" since we don't know which RTEXTBLS libs to use in this case $usr_LIBS = "none" unless $usr_LIBS; } # Set the compiler options from the environment if ( $ENV{FFLAGS} ) { $usr_FFLAGS = "$ENV{FFLAGS}"; # Set usr_LIBS to "none" since we don't know which RTEXTBLS libs to use in this case $usr_LIBS = "none" unless $usr_LIBS; } # Set the compiler options from the command line if ( $usrvar{FFLAGS} ) { # Use all values in this list $usr_FFLAGS = "@{$usrvar{FFLAGS}}"; # Set usr_LIBS to "none" since we don't know which RTEXTBLS libs to use in this case $usr_LIBS = "none" unless $usr_LIBS; } # Set the user defined LIBS from the environment if ( $ENV{LIBS} ) { $usr_LIBS = "$ENV{LIBS}"; } # Set user defined LIBS from the command line if ( $usrvar{LIBS} ) { # Use all values in this list # Note, this will override any definition of usr_LIBS set above $usr_LIBS = "@{$usrvar{LIBS}}"; } # Set user defined INCS from the environment if ( $ENV{INCS} ) { # Use all values in this list $usr_INCS = "$ENV{INCS}"; } # Set user defined INCS from the command line if ( $usrvar{INCS} ) { # Use all values in this list # Note, this will override any definition of usr_INCS set above $usr_INCS = "@{$usrvar{INCS}}"; } # Set the xlf compiler version # with{xlfversion} can be one of xlf12104, xlf13108, xlf14101 if ( $usrvar{xlfversion} ) { # Only the first element of this array is significant, all others are ignored $with{xlfversion} = @{$usrvar{xlfversion}}[0]; if ( scalar(@{$usrvar{xlfversion}})>1 ) { warn "Multiple values for xlfversion found on command line. --> @{$usrvar{xlfversion}} <--\n"; warn "Using xlfversion = $with{xlfversion}\n"; } unless ( $with{xlfversion} eq "xlf12104" or $with{xlfversion} eq "xlf13108" or $with{xlfversion} eq "xlf14101" ) { die "Invalid value for xlfversion = $with{xlfversion}.\n"; } $set_by_usr{xlfversion} = 1; } # Define a list of directory names used to search for source files # path_list_in will contain user supplied dirs # Always include the directory where this script was launched my @path_list_in; push @path_list_in, $CWD; # If the user has supplied any additional dir names on the command line then # prepend them to $path_list_in so that these new dirs will be searched first if ( $usrvar{path} ) { foreach my $dir ( reverse @{$usrvar{path}} ) { # Loop through in reverse order so that the input order # is preserved as dirs are prepended to path_list_in next unless $dir; # Ensure this dir exists die "${Runame}: $dir is not a directory\n" unless -d $dir; # Make sure this is an absolute pathname and strip any trailing "/" $dir = abs_path( $dir ); # Now prepend to the path list unless path list already contains this dir unshift @path_list_in, $dir unless grep /^$dir$/, @path_list_in; } } # If the user has supplied a file containing additional dir names on the command line # then prepend them to $path_list_in so that these new dirs will be searched first if ( $usrvar{path_list} ) { my $path_list_file = @{$usrvar{path_list}}[0]; # Read the list of pathnames, one per line, from the user supplied file my @plist; open(PLIST, "<$path_list_file") or die "Unable to open $path_list_file $!\n"; while () { chomp($_); next if /^\s*#/; next if /^\s*$/; # Use only the first whitespace separated word found on this line my $dir = (split(" ",$_))[0]; # Make sure this is an absolute pathname and strip any trailing "/" $dir = abs_path( $dir ); # Ensure this dir exists die "${Runame}: User supplied directory $dir is not a directory\n" unless -d $dir; # Append to plist push @plist, $dir; } close(PLIST); # Append plist to the list of user supplied dirs push @path_list_in, @plist; } # path_list_dk will contain a list of dirs containing deck (*.dk *.cdk) files my @path_list_dk; if ( $usrvar{pathdk} ) { @path_list_dk = @{$usrvar{pathdk}}; } # If the user has supplied a file containing additional dir names on the command line # then prepend them to $pathdk_list_in so that these new dirs will be searched first if ( $usrvar{pathdk_list} ) { my $pathdk_list_file = @{$usrvar{pathdk_list}}[0]; # Read the list of pathnames, one per line, from the user supplied file my @plist; open(PLIST, "<$pathdk_list_file") or die "Unable to open $pathdk_list_file $!\n"; while () { chomp($_); next if /^\s*#/; next if /^\s*$/; # Use only the first whitespace separated word found on this line my $dir = (split(" ",$_))[0]; # Make sure this is an absolute pathname and strip any trailing "/" $dir = abs_path( $dir ); # Ensure this dir exists die "${Runame}: User supplied pathdk directory $dir is not a directory\n" unless -d $dir; # Append to plist push @plist, $dir; } close(PLIST); if ( scalar(@plist) ) { # Append plist to the list of user supplied paths push @path_list_dk, @plist; } else { warn "** WW ** No directory paths were found in $pathdk_list_file\n"; } } unless ( $set_by_usr{cache_only} ) { # Do not do this when the user has defined cache_only on the command line # If updates have been provided, either via updates=FNAME or model_job=FNAME, # then process these updates and put any modified files into the current dir if ( $run_up2patch and $updates_file ) { # The user has provided updates die "Updates file $updates_file is missing or empty.\n" unless -s $updates_file; die "atmver must also be defined when updates are supplied.\n" unless ($set_by_usr{atmver} or $set_by_usr{modver}); my $srcd_list = ''; if ( scalar(@{$usrvar{path_list}}[0]) ) { $srcd_list = "srcd_list=@{$usrvar{path_list}}[0]"; } print "up2patch modver=$atmver $srcd_list $updates_file\n"; my @sh_out = syscmd( "up2patch modver=$atmver $srcd_list $updates_file" ); foreach ( @sh_out ) { # Preface each line with a string to indicate this came from up2patch print "up2patch: $_\n"; } print "\n"; # If the file "files_created_by_up2patch" exists it will contain a list of # all the files that were created by up2patch and placed in the cwd # Put these file names into a global list that can be used to add these files # to the clean target in the output make file my $up2patch_file_list = "files_created_by_up2patch"; if ( -s $up2patch_file_list ) { open(UPLIST, "<$up2patch_file_list") or die "Unable to open $up2patch_file_list $!\n"; while () {push @up2patch_flist, $_} close(UPLIST); # Remove trailing newlines chomp( @up2patch_flist ); # Also add the file containing this file list push @up2patch_flist, $up2patch_file_list; } } } unless ( $set_by_usr{cache_only} ) { # Do not do this when the user has defined cache_only on the command line if ( $set_by_usr{cancpl_ver} ) { if ( $cccmf_clones_cpl ) { # If the user has supplied a coupler version on the command line then # extract that source from a repository into a local dir and include # this dir in the source path list die "**EE** cancpl_ver=$cancpl_ver but cancpl_repo is not defined.\n" unless $set_by_usr{cancpl_repo}; # Clone the coupler repository my $cmd = "$GIT clone --no-local $cancpl_repo coupler_src"; chomp(my @sh_out = `$cmd 2>&1`); if ( $? ) { foreach (@sh_out) {print "$_\n"} die "** EE ** Problem executing\n $cmd\n"; } foreach (@sh_out) {print "$_\n"} # Check out the requested commit $cmd = "cd coupler_src; git checkout --quiet $cancpl_ver"; chomp(@sh_out = `$cmd 2>&1`); if ( $? ) { foreach (@sh_out) {print "$_\n"} die "** EE ** Problem executing\n $cmd\n"; } foreach (@sh_out) {print "$_\n"} # Extract the sha1 hash associated with this commit $cmd = "cd coupler_src; git rev-parse $cancpl_ver"; chomp(@sh_out = `$cmd 2>&1`); if ( $? ) { foreach (@sh_out) {print "$_\n"} die "** EE ** Problem executing\n $cmd\n"; } $COUPLER_COMMIT = $sh_out[0]; $COUPLER_REPO = $cancpl_repo; # Identify the common source dir in this coupler repo my $coupler_comm_dir = "coupler_src/src/comm"; # make sure coupler_comm_dir is a full pathname without any trailing "/" # before adding it to path_list_in $coupler_comm_dir = abs_path( $coupler_comm_dir ); push @path_list_in, $coupler_comm_dir unless grep /^$coupler_comm_dir$/, @path_list_in; print "Coupler source is in $coupler_comm_dir\n"; } # Disable the old ocean when coupled with the CanCPL $set_by_usr{ocnver} = 0; } if ( $set_by_usr{ocnver} ) { # If the user has supplied an ocean version on the command line then # extract that source from a repository into a local dir and include # this dir in the source path list get_ocn_src( $ocnver, $ocndir, $ocn_user_source ); # make sure ocndir is a full pathname without any trailing "/" # before adding it to path_list_in $ocndir = abs_path( $ocndir ); push @path_list_in, $ocndir unless grep /^$ocndir$/, @path_list_in; # Add a copy of the user supplied cppdefs file file to the ocean dir # This file must be named "CPP_I" in the ocean source dir die "A cppdefs file is required when using ocean code.\n" unless $cppdefs_file; syscmd( "cp -f $cppdefs_file $ocndir/CPP_I" ); } } # Create a separate list of CCRNSRC dirs in order to easily distinguish between # these dirs and any user supplied dirs # First determine the top level dirs to use from the CCRNSRC source tree my @ccrnsrc_list; if ( $CCRNSRC ) { if ( $set_by_usr{atmver} or $set_by_usr{modver} ) { # Include model version dependent subdirs at the top of this list die "CCRNSRC is not defined.\n" unless $CCRNSRC; die "CCRNSRC is not a directory.\n" unless -d $CCRNSRC; @ccrnsrc_list = ( "$CCRNSRC/source/lsmod/agcm/$atmver", "$CCRNSRC/source/lssub/model/agcm/$atmver" ); # Add subdirs that are not model version dependent push @ccrnsrc_list, ( "$CCRNSRC/source/lssub/comm", "$CCRNSRC/source/lssub/diag", "$CCRNSRC/source/lssub/plots/ccrn" ); } else { # Do not use any model version dependent subdirs from CCRNSRC if ( $CCRNSRC ) { # Only include these dirs if CCRNSRC is defined and is a dir die "CCRNSRC is not a directory.\n" unless -d $CCRNSRC; @ccrnsrc_list = ( "$CCRNSRC/source/lssub/comm", "$CCRNSRC/source/lssub/diag", "$CCRNSRC/source/lssub/plots/ccrn" ); } } # Possibly append lspgm dirs containing *.vd files to this list my $use_lspgm = 0; if ($use_lspgm) { push @ccrnsrc_list, ( "$CCRNSRC/source/lspgm/diag", "$CCRNSRC/source/lspgm/plots" ); } if ($verbose > 10) { print "ccrnsrc_list:\n\t",join("\n\t",@ccrnsrc_list),"\n"; } } # Define path_list_ccc by expanding dirs found in ccrnsrc_list recursively my @path_list_ccc; if ( scalar(@ccrnsrc_list) ) { foreach my $dir ( @ccrnsrc_list ) { # Ensure this is an absolute pathname and strip any trailing "/" $dir = abs_path( $dir ); # Find all subdirs below this dir # Avoiding RCS, CVS and .git dirs as well as any dirs that start with "tmp_" my @dlist = syscmd( "find $dir -follow -type d ! -name RCS ! -name CVS ! -name .git ! -name tmp_*"); die "Problem finding dirs below $dir." unless scalar(@dlist); foreach ( @dlist ) { next unless $_; # Ignore dirs for which the user does not have rx permissions next unless -r; next unless -x; my $exclude = 0; foreach my $d ( sort keys %exclude_dir ) { # Ignore any dir path that contains this key as a dir in its path if ( m!(/$d/|/$d$)! ) { $exclude = 1; last; } } next if $exclude; push @path_list_ccc, $_; } } if ($verbose > 10) { print "path_list_ccc:\n\t",join("\n\t",@path_list_ccc),"\n"; } } # Create a combined list @path_list_all = @path_list_in; foreach my $dir ( @path_list_ccc ) { push @path_list_all, $dir unless grep /^$dir$/, @path_list_all; } if ($verbose > 1) { print "input path list: ",scalar(@path_list_in),"\n ",join("\n ",@path_list_in),"\n"; print "CCRNSRC path list: ",scalar(@path_list_ccc),"\n ",join("\n ",@path_list_ccc),"\n"; } unless ( $set_by_usr{cache_only} ) { # Do not do this when the user has defined cache_only on the command line # Go through flist once expanding any entries that contain shell wildcards my @flist_tmp; foreach my $file ( @flist ) { # Check to see if $file contains any shell wildcards # If so, convert these shell wildcards to perl regexes and expand if ( has_shell_wild_card( $file ) ) { # The input pattern contains shell wildcard characters # replace '[!' with '[^' my $file_in = $file; $file =~ s/\Q[!/[^/g; # replace '*' with '.*' $file =~ s/\*/.*/g; # replace '?' with '.' $file =~ s/\?/./g; # Split $file into a path portion and a file name portion my ($name, $path, $sfx) = fileparse("$file",()); #TODO# if ( has_shell_wild_card( $path ) ) { #TODO# # If the path portion contains shell wildcards then expand them #TODO# my @paths = find_dirs_in( $path, 0); #TODO# } #TODO# print "dirs in $path:\n\t",join("\n\t",find_dirs_in( $path, 0)),"\n"; my @hits = find_files_in("$path", 0, "$name$sfx"); if ( scalar(@hits) ) { push @flist_tmp, @hits; print "Expanded $file_in to the following:\n\t",join("\n\t", @hits),"\n" if $verbose > -1; } else { warn "** WW ** No files matched --> $file_in <--\n" if $verbose > -1; push @flist_tmp, $file_in; } } else { # If there are no wild cards then simply append to the tmp list push @flist_tmp, $file; } } @flist = @flist_tmp if scalar( @flist_tmp ); undef @flist_tmp; # Look through certain directories when user supplied file names # are not absolute pathnames or are not found in the cwd foreach my $file ( @flist ) { if ( -e $file ) { # If the file exists "as is" then simply append it to the list push @flist_tmp, $file unless grep /^$file$/, @flist_tmp; next; } # Search all directories on the user supplied path list my $found_file = 0; foreach my $dir ( @path_list_in ) { opendir(DIR, $dir) or die "$!"; foreach my $fn (readdir DIR) { if ( $fn eq $file ) { # Add this full pathname to the file list $fn = abs_path( "$dir/$fn" ); push @flist_tmp, $fn unless grep /^$fn$/, @flist_tmp; $found_file = 1; last; } } closedir(DIR); last if $found_file; } next if $found_file; die "Unable to find $file in @path_list_in\n"; # Otherwise look through a few likely locations for a match my $matched = 0; # If the file does not exist then look in selected locations if ( $set_by_usr{ocnver} and ! $matched ) { # The user has requested ocean source be used, look in ocndir my @hits = find_files_in("$ocndir", 1, $file); foreach my $hit ( @hits ) { push @flist_tmp, $hit unless grep /^$hit$/, @flist_tmp; my ($name, $path, $sfx) = fileparse("$hit",()); print "Found input file $name$sfx \tin $path\n" if $verbose > -1; } $matched = scalar( @hits ); } if ( $set_by_usr{atmver} or $set_by_usr{modver} and ! $matched ) { # The user has requested atm source be used, look in the # lsmod and lssub model dirs and any subdirs found therein my @hits = find_files_in("$CCRNSRC/source/lsmod/agcm/$atmver", 1, $file); push @hits, find_files_in("$CCRNSRC/source/lssub/model/agcm/$atmver", 1, $file); foreach my $hit ( @hits ) { push @flist_tmp, $hit unless grep /^$hit$/, @flist_tmp; my ($name, $path, $sfx) = fileparse("$hit",()); print "Found input file $name$sfx \tin $path\n" if $verbose > -1; } $matched = scalar( @hits ); } unless ( $matched ) { # Also look in the lssub directory in specific subdirs my @hits = find_files_in("$CCRNSRC/source/lssub/comm", 1, $file); push @hits, find_files_in("$CCRNSRC/source/lssub/diag", 1, $file); foreach my $hit ( @hits ) { push @flist_tmp, $hit unless grep /^$hit$/, @flist_tmp; my ($name, $path, $sfx) = fileparse("$hit",()); print "Found input file $name$sfx \tin $path\n" if $verbose > -1; } $matched = scalar( @hits ); } unless ( $matched ) { # Also look in the lspgm/diag and lspgm/plots directories my @hits = find_files_in("$CCRNSRC/source/lspgm/diag", 1, $file); # TODO # files in this plots dir need to be linked against NCARG libs # push @hits, find_files_in("$CCRNSRC/source/lspgm/plots", 1, $file); foreach my $hit ( @hits ) { push @flist_tmp, $hit unless grep /^$hit$/, @flist_tmp; my ($name, $path, $sfx) = fileparse("$hit",()); print "Found input file $name$sfx \tin $path\n" if $verbose > -1; } $matched = scalar( @hits ); } # Hold off on looking for *.vd files in the lspgm dir when a *.f file name was # supplied by the user. This may be desired at some point but right now it # seems like the wrong thing to do. The user should request *.vd to have # that file complied. if ( 0 and ! -e $file ) { # If the input file has a ".f" suffix then look for a file # named "$base.vd" in the lspgm/diag or lspgm/plots directory my ($name, $path, $sfx) = fileparse( "$file", (q(\.f)) ); if ( $sfx eq ".f" ) { my $test_file = "$name.vd"; my @hits = find_files_in("$CCRNSRC/source/lspgm/diag", 1, $test_file); # TODO # files in this plots dir need to be linked against NCARG libs # push @hits, find_files_in("$CCRNSRC/source/lspgm/plots", 1, $test_file); if ( scalar(@hits) ) { $test_file = $hits[0]; if ( scalar(@hits) > 1 ) { warn "Multiple files match input file $test_file\n"; warn " ",join("\n ", @hits),"\n"; warn "using $test_file\n"; } my ($test_name, $test_path, $test_sfx) = fileparse("$test_file",()); print "Found file $test_name$test_sfx in $test_path\n" if $verbose > -1; # The name of the source file create is returned from convert_vd_to_f $file = convert_vd_to_f( $test_file ); print "Created input file $file from $test_path$test_name$test_sfx\n" if $verbose > -1; # Add this to the veryclean list if not already there push @veryclean_flist, $file unless grep /^$file$/,@veryclean_flist; } } } } @flist = @flist_tmp if scalar( @flist_tmp ); # Ensure that all file names found in @flist are full pathnames to actual files foreach my $file ( @flist ) { # Ensure the file exists and in not empty die "The input file $file is missing or empty\n" unless -s "$file"; # If this file has a ".vd" suffix then convert it to a fortran source file my ($name, $path, $sfx) = fileparse( "$file", (q(\.vd)) ); if ( $sfx eq ".vd" ) { $file = convert_vd_to_f( $file ); print "Created $file from $path$name$sfx\n" if $verbose > -1; # Add this to the veryclean list if not already there push @veryclean_flist, $file unless grep /^$file$/,@veryclean_flist; } # Make sure this is an absolute pathname and remove any trailing "/" $file = abs_path( $file ); } if ($verbose > -1 and !$list_only and !$depends_file and !$depends_ccrnsrc) { if ( scalar(@flist) == 1 ) { print "\n",scalar(@flist)," build target:\n ",join("\n ",@flist),"\n" if scalar(@flist); } elsif ( scalar(@flist) > 1 ) { print "\n",scalar(@flist)," build targets:\n ",join("\n ",@flist),"\n" if scalar(@flist); } } # Identify all files on path_list_in that will potentially be compiled # These file names will be keys in %compile_file foreach my $dir ( @path_list_in ) { opendir(DIR, $dir) or die "$!"; foreach my $fn (readdir DIR) { $fn = abs_path( "$dir/$fn" ); # Ignore anything that is not a regular file next unless -f "$fn"; my ($name, $path, $sfx) = fileparse("$fn", @suffix_list); next unless $sfx; $compile_file{"$name$sfx"} = 1; } closedir(DIR); } } # Scan and preprocess all source files # This will read files into memory then preprocess and analyze each file # Anaysis results in population of the following hashes # %source { abspath } = actual source, after processing # %full_path { file_basename } = abspath ! absolute path to this file # %freefmt { file_basename } = 0 or 1 ! is this free format or fixed format # %is_main { file_basename } = 0 or 1 ! is this a main program or other # %is_target { file_basename } = 0 or 1 ! does this require a target in the makefile # %has_cppdefs { file_basename } = 0 or 1 ! does this file contain cpp directives # %has_ddelim { file_basename } = 0 or 1 ! does this file contain "$" delimited text # %contains_mod { file_basename } = 0 or 1 ! does this file contain modules # %uses_mod { file_basename } = 0 or 1 ! does this file use modules # %func_path { function_name } = abspath ! path to file containing this function # %sub_path { subroutine_name } = abspath ! path to file containing this subroutine # %mod_path { module_name } = abspath ! path to file containing this function # %contains_mod { file_basename } = T or F ! does this file contain modules # %uses_mod { file_basename } = T or F ! does this file use modules # First process CCRNSRC files in directory order and write this data to a cache file # but only when atmver has been defined by the user #xxxif ( $set_by_usr{atmver} or $set_by_usr{modver} ) { if ( scalar( @path_list_ccc ) ) { # Determine if the cache needs to be (re)created if ( $usrvar{cache_only} ) { # Always create the cache file when cache_only appears on the command line $create_atm_cache = 1; } else { # Otherwise it depends on whether or not the cache file exists # and how old it is if it does exist if ( -s $atm_cache_file ) { # The cache file already exisits, decide if it should be overwritten my $mtime = (stat $atm_cache_file)[9]; # delta is the age of the existing cache file in seconds my $delta = time() - $mtime; if ( $delta > 64800 ) { my $mdays = $delta/86400.0; if ( -w $atm_cache_file ) { # Recreate if the cache has not been modified in the last 18 hours # and the invoking user has write access $create_atm_cache = 1; printf "The cache was last modified %6.1f days ago. It will be recreated.\n",$mdays if $verbose > -1; } else { # Otherwise warn the user that this cache file could be out of date # but do not create it even if the user has requested tat it be created # via the --wcache command line option $create_atm_cache = 0; printf "** WW ** The cache was last modified %6.1f days ago. It may be out of date.\n",$mdays if $verbose > -1; } } } else { # Create the cache file if it does not already exist $create_atm_cache = 1; } } if ( $create_atm_cache ) { if ( -s $atm_cache_file ) { print "\nRecreating atm cache file $atm_cache_file\n" if $verbose > -1; } else { print "\nCreating atm cache file $atm_cache_file\n" if $verbose > -1; } foreach ( sort keys %exclude_dir ) { print "Excluding directory $_\n" if $verbose > -1; } foreach ( sort keys %exclude_file ) { print "Excluding file $_\n" if $verbose > -1; } # Process all CCRNSRC files scan_path_list( @path_list_ccc ); # Write CCRNSRC hash info to a "Storeable" file open(CACHE, ">$atm_cache_file") or die "** EE ** Opening ${atm_cache_file}: $!\n"; nstore_fd(\%source, *CACHE) or die "Can't store source to $atm_cache_file\n"; nstore_fd(\%func_path, *CACHE) or die "Can't store func_path to $atm_cache_file\n"; nstore_fd(\%sub_path, *CACHE) or die "Can't store sub_path to $atm_cache_file\n"; nstore_fd(\%mod_path, *CACHE) or die "Can't store mod_path to $atm_cache_file\n"; nstore_fd(\%freefmt, *CACHE) or die "Can't store freefmt to $atm_cache_file\n"; nstore_fd(\%is_main, *CACHE) or die "Can't store is_main to $atm_cache_file\n"; nstore_fd(\%is_target, *CACHE) or die "Can't store is_target to $atm_cache_file\n"; nstore_fd(\%full_path, *CACHE) or die "Can't store full_path to $atm_cache_file\n"; nstore_fd(\%has_cppdefs, *CACHE) or die "Can't store has_cppdefs to $atm_cache_file\n"; nstore_fd(\%has_ddelim, *CACHE) or die "Can't store has_ddelim to $atm_cache_file\n"; nstore_fd(\%contains_mod, *CACHE) or die "Can't store contains_mod to $atm_cache_file\n"; nstore_fd(\%uses_mod, *CACHE) or die "Can't store uses_mod to $atm_cache_file\n"; close(CACHE); # Destroy all these hashes so they they can be recreated in the correct order below undef %source; undef %func_path; undef %sub_path; undef %mod_path; undef %freefmt; undef %is_main; undef %is_target; undef %full_path; undef %has_cppdefs; undef %contains_mod; undef %uses_mod; undef %has_ddelim; # Also destroy scanned_this_file so that files found in @path_list_in that also # live within CCRNSRC will be rescanned undef %scanned_this_file; } } # Stop here when cache_only appears on the command line exit if $usrvar{cache_only}; # Process the files named on the command line so that any procedures found # in one of these files will take precedence over the same procedure found elswhere foreach my $file ( @flist ) { scan_file( $file ); } # Then process the remainder of the files found in user supplied dirs scan_path_list( @path_list_in ); if ( -s $atm_cache_file ) { # Read dependency info from the cache file containing agcm file data read_cache( $atm_cache_file ); } if ( $print_cache_info ) { # Display info read from the current cache file print_cache( $atm_cache_file ); exit; } if ( $verbose > 1 ) { # Dump info determined by scanning the input source files to stdout print_scan_info($verbose); } if ($verbose > 10) { foreach my $key ( keys %sub_path ) { printf "subroutine %30s FOUND IN %s\n", $key, $sub_path{$key}; } } if ($verbose > 10) { foreach my $key ( keys %func_path ) { printf "function %30s FOUND IN %s\n", $key, $func_path{$key}; } } if ($verbose > 10) { foreach my $key ( sort keys %is_target ) { next unless $is_target{$key}; printf "file %20s is a potential target ...FOUND IN %s\n", $key, $full_path{$key}; } } if ($verbose > 10) { my $count = 0; foreach my $key ( keys %has_cppdefs ) { next unless $has_cppdefs{$key}; $count++; printf "cpp directives EXIST IN %s\n", $full_path{$key}; } if ($count>0) { print "$count files contain cpp directives.\n"; } } if ($verbose > 10) { my $count = 0; foreach my $key ( keys %has_ddelim ) { next unless $has_ddelim{$key}; $count++; printf "\"\$\" delimited text segments EXIST IN %s\n", $full_path{$key}; } if ($count>0) { print "$count files contain \"\$\" delimited text segments.\n"; } } if ($verbose > 10) { foreach my $key ( keys %mod_path ) { printf "module %30s FOUND IN %s\n", $key, $mod_path{$key}; } } if ($verbose > 10) { foreach my $key ( keys %is_main ) { next unless $is_main{$key}; printf "main program %20s FOUND IN %s\n", $key, $full_path{$key}; } } # For each file found on the command line determine dependencies recursively foreach my $file ( @flist ) { # Ensure an absolute path name $file = abs_path( $file ); my ($name, $path, $sfx) = fileparse("$file", @suffix_list); if ( $exclude_file{"$name$sfx"} ) { if ( $verbose > -1 ) { print " Excluding $file\n" unless ($list_only or $depends_file or $depends_ccrnsrc); } next; } else { if ( $verbose > -1 ) { print "Processing $file\n" unless ($list_only or $depends_file or $depends_ccrnsrc); } } unless ($sfx) { print "Missing or invalid suffix for file $file ...Ignored.\n" if $verbose > -1; next; } # First add this file to DEP_list push @DEP_list, $file unless grep /^$file$/, @DEP_list; # Find all files that are required by procedures in the current file # and add them to the dependency list @DEP_list # find_depends will populate the following hashes # %child_of{ file_basename } # %not_found{ include file: inc_file_name or # module: module_name or # subroutine: sub_name } # %scanned_by_find_dep{ abspath } # keys in the following hashes are full pathnames and the associated # values are list references pointing to lists of file names on which # the key file depends # %mod_depends{ abspath } a list of file names containing module dependencies # %inc_depends{ abspath } a list of file names containing include dependencies # %all_depends{ abspath } a list of all dependent file names foreach my $p (find_depends({FILE => $file, VERBOSE => $verbose})) { push @DEP_list, $p unless grep /^$p$/, @DEP_list; } } if ($verbose > 5) { foreach my $fpath ( sort keys %inc_depends ) { if ( scalar(@{$inc_depends{$fpath}}) ) { print "includes used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$inc_depends{$fpath}})),"\n"; } else { print "No included files required by $fpath\n"; } } print "=========================================\n"; } if ($verbose > 5) { foreach my $fpath ( sort keys %mod_depends ) { if ( scalar(@{$mod_depends{$fpath}}) ) { print " modules used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$mod_depends{$fpath}})),"\n"; } else { print "No modules required by $fpath\n"; } } print "=========================================\n"; } if ($verbose > 5) { foreach my $fpath ( sort keys %all_depends ) { if ( scalar(@{$all_depends{$fpath}}) ) { print " files used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$all_depends{$fpath}})),"\n"; } else { print "No external files required by $fpath\n"; } } print "=========================================\n"; } if ( 0 and $set_by_usr{ocnver} ) { # If the user has requested that ocean source be used # then process all *.F files in the ocean dir foreach my $file ( glob("$ocndir/*.F") ) { # Ensure an absolute path name $file = abs_path( $file ); my ($name, $path, $sfx) = fileparse("$file", @suffix_list); # Skip the ocean driver when coupled if ( $with{coupled} ) { next if "$name$sfx" eq "ocn_driver.F"; } # Skip files already present in DEP_list next if grep /^$name$sfx$/, map {m@^.*/(.*)$@} @DEP_list; if ( $verbose > 10 ) { print "Processing ocean file $file\n"; } # Make sure this file is present in DEP_list push @DEP_list, $file unless grep /^$file$/, @DEP_list; # Find dependencies recursively for each file foreach my $p (find_depends({FILE => $file, VERBOSE => $verbose})) { push @DEP_list, $p unless grep /^$p$/, @DEP_list; } } } if ( $verbose > 10 ) { foreach my $parent (sort keys %child_of) { printf "child of %12s = ",$parent; print "@{$child_of{$parent}}\n"; } } # The child_of hash is created in find_depends and contains a list of # routines that are called from the subroutine named in each hash key foreach my $parent (sort keys %child_of) { if ($verbose > 10) { printf "child of %12s = ",$parent; print "@{$child_of{$parent}}\n"; } # determine the parent(s) of each routine foreach my $child (@{$child_of{$parent}}) { unless (grep /^$parent$/, @{$parent_of{$child}}) { push @{ $parent_of{$child} }, $parent; } } } if ( $list_only ) { my @out_list; for my $fpath ( @DEP_list ) { my $file = basename $fpath; # Ignore files that have names beginning with CPP_I next if $file =~ /^CPP_I/; # Ignore cpl_global_cppdefs next if $file =~ /^cpl_global_cppdefs/; push @out_list, $fpath; } if ( scalar(@out_list) ) { @out_list = sort_by_dep( @out_list ); @out_list = map {basename $_} @out_list; print join(" ",@out_list),"\n"; } exit 0; } if ( $depends_file or $depends_ccrnsrc ) { # Create a file containing a list of dependent files if ( $depends_file ) { open(DEP_FILE, ">$depends_file") or die "Unable to read file $depends_file $!\n"; print DEP_FILE "#=#=# Dependencies for: ",join(" ",map {basename $_} @flist),"\n"; my @recipe_list; foreach my $fpath ( @DEP_list ) { # Write a comment line containing the source file base name and its full pathname my $file = basename $fpath; $file =~ s/\.(f|f90|f95|F|F90|F95|dk)$/.o/; $file =~ s/^xit2\.cdk$/xit2.o/; push @recipe_list, "${file}: $fpath\n"; } @recipe_list = sort @recipe_list; print DEP_FILE @recipe_list; } my @cccsrc; foreach my $fpath ( @DEP_list ) { if ( $depends_ccrnsrc == 1 ) { # Create a list of all files that live below $CCRNSRC/source push @cccsrc, $fpath if $fpath =~ m<^\s*$CCRNSRC/source>; } elsif ( $depends_ccrnsrc == 2 ) { # Create a list of all files that live below $CCRNSRC/source/lsmod push @cccsrc, $fpath if $fpath =~ m<^\s*$CCRNSRC/source/lsmod>; } elsif ( $depends_ccrnsrc == 3 ) { # Create a list of all files that live below $CCRNSRC/source/lssub push @cccsrc, $fpath if $fpath =~ m<^\s*$CCRNSRC/source/lssub>; } # Ignore any file that does not have any dependencies next unless scalar( @{$all_depends{$fpath}} ); my $file = basename $fpath; # Sort this list of dependencies according to dependencies withing the list my @deps = sort_by_dep( @{$all_depends{$fpath}} ); # Use only the basename in what follows @deps = map {basename $_} @deps; # Remove $file from this deps list if present my $offset = -1; for (my $i=0; $i<=$#deps; $i++) { $offset = $i if $deps[$i] eq $file; } splice @deps, $offset, 1 if $offset > -1; my $remove_cpp_i = 0; if ( $remove_cpp_i ) { # Remove any files having names beginning with CPP_I s/^CPP_I.*$// for @deps; } # Remove any empty elements from deps my @clean_deps = grep { /\S/ } @deps; @deps = @clean_deps; if ( scalar(@deps) and $depends_file ) { # Write a comment line containing the source file names followed # by a make style dependency line using object file names # print DEP_FILE "#=#=# ${file}: ",join(" ",@deps),"\n"; $file =~ s/\.(f|f90|f95|F|F90|F95|dk)$/.o/; # Treat xit2.cdk as a special case $file =~ s/^xit2\.cdk$/xit2.o/; s/\.(f|f90|f95|F|F90|F95|dk)$/.o/ for @deps; # Treat xit2.cdk as a special case s/^xit2\.cdk$/xit2.o/ for @deps; print DEP_FILE "${file}: ",join(" ",@deps),"\n"; } } if ( $depends_ccrnsrc ) { @cccsrc = sort_by_dep( @cccsrc ); @cccsrc = map {basename $_} @cccsrc; print join(" ",@cccsrc),"\n" if $verbose > -1; } if ( $depends_file ) { close(DEP_FILE); print "Created $depends_file containing dependencies for: ", join(", ",map {basename $_} @flist),"\n" if $verbose > -1; } exit 0; } if ($verbose > -1) { # print not_found's foreach my $k (sort {(split(":",$a))[1] cmp (split(":",$b))[1]} keys %not_found) { printf "%-35s ...NOT FOUND...",$k; my ($subtype,$subname) = split /\s*:\s*/,$k; if ($subname) { if (exists $parent_of{$subname}) { if ( $subtype =~ /^\s*module\s*$/i ) { print " used by: @{$parent_of{$subname}}\n"; } else { print " called from: @{$parent_of{$subname}}\n"; } } elsif ($subtype eq "include file") { print " required by: ",join(" ", map(m@^.*/(.*)$@, @{$not_found{$k}})),"\n"; } else { print "\n"; } } else { print "\n"; } if ($verbose > 2) { print " required by:\n"; printf " %s\n",join("\n ",@{$not_found{$k}}); } } } # Create a Makefile that will compile this source file write_makefile( $make_file_name, \@flist ); if ( $run_make ) { # Run the make file just created print "\n$MAKE -f $make_file_name\n" if $verbose > -1; syscmd( "$MAKE -f $make_file_name", 1 ); } exit 0; ######################################################## ##################### End of main ###################### ######################################################## sub sort_by_dep { # Use the all_depends hash to sort a user supplied list of pathnames by dependency use strict; my @with_deps; my @no_deps; my @sorted; foreach (@_) { if ( scalar(@{$all_depends{$_}}) ) { push @with_deps,$_; } else { push @no_deps,$_; } } @sorted = sort { my $adep=0; foreach (@{$all_depends{$a}}) {if ($_ eq $b) {$adep=1; last}} my $bdep=0; foreach (@{$all_depends{$b}}) {if ($_ eq $a) {$bdep=1; last}} $adep <=> $bdep; } @with_deps; # Put the sorted list of files that do have dependencies at the end of the returned # list and the files with no dependencies at the beginning return @no_deps,@sorted; } sub has_shell_wild_card { # Return true if the input string contains a shell wild character # Currently this looks for one of *,?,[,] use strict; if ( $_[0] =~ m<(\Q*\E|\Q?\E|\Q[\E.*?\Q]\E)> ) { return 1; } return undef; } sub convert_vd_to_f { # Given a variable dimension file (typically from the lspgm dir), convert it # to pure fortran by replacing any $...$ delimited strings with numbers use strict; my $fname = shift; die "convert_vd_to_f: Input file name is missing.\n" unless $fname; my ($name, $path, $sfx) = fileparse("$fname", (q(\.vd))); die "convert_vd_to_f: Input file --> $fname <-- is not variable dimension.\n" unless $sfx; # The output file name will be the same name but with a ".f" suffix my $out_fname = "${name}.f"; # Read the input file into memory, replacing $...$ delimited strings on the fly my $fsrc = ""; open(FTMP, "<$fname") or die "Unable to read file $fname$!\n"; while () { # expand tabs as each line is read my $line = expand($_); chomp($line); if ( $line =~ /^C/i ) { # Simply append comment lines and skip to the next line $fsrc .= "$line\n"; next; } # Truncate all source lines longer than 72 characters # This is necessary becuase some of the legacy source code contains # invalid fortran outside of this 72 character line length if ( length($line) > 72 ) { $line = substr($line,0,72); } # @hits will contain all $...$ delimited strings found on this line my @hits = $line =~ /(\$.*?\$)/g; foreach my $hit (@hits) { # Strip "$" delimiters to get the name of the hash key my ($key) = $hit =~ /^\$(.*?)\$$/; $key = uc($key); if ( defined $vardim{$key} ) { # There is a value defined for this $...$ delimited string, use it $line =~ s/\Q$hit/$vardim{$key}/g; } else { # This $...$ delimited string does not have a known value warn "** WW ** Unknown value for variable dimension parameter --> $key <-- Ignored\n"; warn "** WW ** This may cause a compile error if \$$key\$ is not inside a string.\n"; } } # Add a continuation line if this line now exceeds 72 characters # and append the line (or lines) to fsrc $fsrc .= wrap_ffixed_line( "$line\n" ); } close(FTMP); # Write the processed source to the output file open(FTMP, ">$out_fname") or die "Unable to write file $out_fname$!\n"; print FTMP $fsrc; close(FTMP); # Filter the source in the output file to fix some quirks in legacy code my ($filtered_fsrc, $change) = filter_src_file( $out_fname, $fsrc ); if ( $change ) { # If the file was changed then overwrite the existing version open(FTMP, ">$out_fname") or die "$! Stopped"; print FTMP $filtered_fsrc; close(FTMP); } if ( $verbose > 10 ) { print "Created $out_fname from $fname\n"; } return $out_fname; } sub def_var_dim_par { # Define a hash containing replacement values for $...$ delimited strings # that are found in CCCma variable dimension fortran source code # This is derived from the file pgmparm.f use strict; sub MIN { my $a = shift; my $b = shift; return $a < $b ? $a : $b; } sub MAX { my $a = shift; my $b = shift; return $a > $b ? $a : $b; } # Set values for the subset of parameters that # will be used to define all other parameters my $ILEV = 300; # number of model levels my $PLV = 300; # number of pressure levels my $LON = 2048; # number of grid longitudes my $LAT = 1024; # number of grid latitudes my $LRT = 1024; # n spectral truncation wave number my $LMT = 1024; # m spectral truncation wave number my $TSL = 185280; # maximum time series length my $KTR = 2; # spectral truncation type (0=rhomboidal, 2=triangular) my $BLN = 2048; # max lon in certain files my $BLT = 1025; # max lat in certain files my $MACHINE = 1; # 1 => 64 bit words 2 => 32 bit words # Use the parameters above to define the set of parameters defined at the # top of the program found in the file pgmparm.f my $LR = $LRT + 1; my $LM = $LMT + 1; # Determine LA according to the values for LR and LM # representative values for triangular truncation (KTR = 2) # LA = 2146; # => LR = LM = 65 # LA = 8386; # => LR = LM = 129 # LA = 33154; # => LR = LM = 257 # LA = 131842; # => LR = LM = 513 # LA = 525826; # => LR = LM = 1025 my $LMP = $LM + 1; my @LSR; $LSR[0] = 1; if ( $KTR == 0 ) { # Rhomboidal truncation for (my $m=2; $m<=$LMP; $m++) { $LSR[$m-1] = $LSR[$m-2] + $LR; } } elsif ( $KTR == 2 ) { # Triangular truncation for (my $m=2; $m<=$LMP; $m++) { $LSR[$m-1] = $LSR[$m-2] + $LR - ($m-2); } } else { die "def_var_dim_par: Invalid value for KTR = $KTR\n"; } my $LA = $LSR[$LMP-1]; undef @LSR; my $L = $ILEV; my $PL = $PLV; $L = MAX($L,$PL); my $I = $LON + 1; my $J = $LAT; my $M = $LM; my $N = $LR; my $R = $LA; my $RPM = $R + $M; my $NLM = 3 * ($M - 1) + $M; my $BI = $BLN + 1; my $BJ = $BLT; my $V = $MACHINE; my $NTRAC = 500; my $PTMIN = 1.E-10; $vardim{"PTMIN"} = $PTMIN; $vardim{"I"} = $I; $vardim{"IM1"} = $I-1; $vardim{"IP1"} = $I+1; $vardim{"64IP1"} = 64 * ( $I+1); $vardim{"64IP1P1"} = 64 * ( $I+1)+1; $vardim{"LIP3"} = $L * ($I+3); $vardim{"2LIP3"} = 2 * $L * ($I+3); $vardim{"13LHI"} = 13 * $L * int( 0.5 * ($I+1) ); $vardim{"17LHI"} = 17 * $L * int( 0.5 * ($I+1) ); $vardim{"LREC"} = ($I+1) * $L * (4+$NTRAC); $vardim{"IJ"} = $I * $J; $vardim{"2IJ"} = 2 * $I * $J; $vardim{"26IJ"} = 26 * $I * $J; $vardim{"40IJ"} = 40 * $I * $J; $vardim{"HIJ"} = int( ($I*$J+1)/2.0 ); $vardim{"IJP10"} = $I * $J + 10; $vardim{"LIJ"} = $L * $I * $J; $vardim{"LP1IJ"} = ($L+1) * $I * $J; $vardim{"PLIJ"} = $PL * $I * $J; $vardim{"XIJ"} = MAX( $I, $J); $vardim{"26XIJ"} = 26 * MAX( $I, $J); $vardim{"XIP1J"} = MAX( $I+1, $J); $vardim{"X100J"} = MAX(100, $J); $vardim{"JX100J"} = $J * MAX(100, $J); $vardim{"LXIJ"} = $L * MAX( $I , $J); $vardim{"LXIP1J"} = $L * MAX( $I+1, $J); $vardim{"J"} = $J; $vardim{"JLP2LP2"} = $J * ($L+2)*( $L+2); $vardim{"BI"} = $BI; $vardim{"BIP3"} = $BI + 3; $vardim{"2BIP3"} = 2 * ($BI+3); $vardim{"3BIP3"} = 3 * ($BI+3); $vardim{"3HBIP3"} = 3 * int( ($BI+4)/2.0 ); $vardim{"BIP5"} = $BI + 5; $vardim{"HBIHBJ"} = ( int( ($BI+1)/2.0)-1 ) * int( ($BJ+1)/2.0 ); $vardim{"BJ"} = $BJ; $vardim{"HBJ"} = int( ($BJ+1)/2.0 ); $vardim{"BIJ"} = $BI * $BJ; $vardim{"XBIBJ"} = MAX( $BI, $BJ); $vardim{"BIJP10"} = $BI * $BJ + 10; $vardim{"LBJ"} = $L * $BJ; $vardim{"LBIJ"} = $L * $BI * $BJ; $vardim{"LXBIBJ"} = $L * MAX( $BI, $BJ); $vardim{"L2RAIP1J"} = $L * (2*($R+$M) + ($I+1)*$J); $vardim{"L"} = $L; $vardim{"LP1"} = $L + 1; $vardim{"LM1"} = $L - 1; $vardim{"LP2"} = $L + 2; $vardim{"LM3"} = $L - 3; $vardim{"8L"} = 8 * $L; $vardim{"4LP3"} = 4 * $L + 3; $vardim{"LL"} = $L * $L; $vardim{"X33L"} = MAX( 33, $L ); $vardim{"X50L"} = MAX( 50, $L ); $vardim{"PL"} = $PL; $vardim{"PLP1"} = $PL + 1; $vardim{"MAXC"} = MAX( ($M+1)*$J, ($R+$M) ); $vardim{"2MAXC"} = 2 * MAX( ($M+1)*$J, ($R+ $M) ); $vardim{"M"} = $M; $vardim{"2MM"} = 2 * $M * $M; $vardim{"MP1"} = $M + 1; $vardim{"2MP1"} = 2 * ( $M+1); $vardim{"NLM"} = $NLM; $vardim{"NLMNLM"} = $NLM * $NLM; $vardim{"6MP1"} = 6 * ($M+1); $vardim{"MP1J"} = ($M+1) * $J; $vardim{"2MP1J"} = 2 * ($M+1)*$J; $vardim{"MP1JL"} = ($M+1) * $J * $L; $vardim{"N"} = $N; $vardim{"NPM"} = $N + $M; $vardim{"R"} = $R; $vardim{"2R"} = 2 * $R; $vardim{"RPM"} = $R + $M; $vardim{"2RPM"} = 2 * ($R+$M); if ( 4*($R+$M)*($M+1) > 6000000 ) { $vardim{"2RPM2MP1"} = 6000000; } else { $vardim{"2RPM2MP1"} = 4 * ($R+$M) * ($M+1); } $vardim{"RP2M"} = $R + (2*$M); $vardim{"RP2MP1"} = $R + (2*$M) + 1; $vardim{"RL"} = $R * $L; $vardim{"2RL"} = 2 * $R * $L; $vardim{"R2LP1"} = $R *(2*$L+1); $vardim{"RLP1"} = $R * ($L+1); $vardim{"6RPML"} = 6 * ($R+$M) * $L; $vardim{"HTSL"} = int( ($TSL+1)/2.0 ); $vardim{"TSL"} = $TSL; $vardim{"TSLP1"} = $TSL + 1; $vardim{"2TSLP1"} = 2 * $TSL + 1; $vardim{"6TSL"} = 6 * $TSL; $vardim{"6TSLP1"} = 6 * $TSL + 1; $vardim{"6TSLP18"} = 6 * $TSL + 18; $vardim{"7TSL"} = 7 * $TSL; $vardim{"7TSLP1"} = 7 * $TSL+1; $vardim{"12TSL"} = 12 * $TSL; $vardim{"1025TSL"} = MIN( 1025*$TSL, MAX(13*$TSL, 1025*10241) ); $vardim{"WRKS"} = MAX( ($I+3)*$L+64*($I+1), 2*$R ); $vardim{"V"} = $V; $vardim{"JV"} = $J * $V; $vardim{"IJV"} = $I * $J * $V; $vardim{"XIJV"} = MAX( $I, $J ) * $V; $vardim{"JLP2LP2V"} = $J * ($L+2) * ($L+2) * $V; $vardim{"BJV"} = $BJ * $V; $vardim{"BIV"} = $BI * $V; $vardim{"BIJV"} = $BI * $BJ * $V; $vardim{"BIJP10V"} = 10 + $BI * $BJ * $V; $vardim{"2RPMV"} = 2 * ($R+$M) * $V; $vardim{"2MAXCV"} = 2 * MAX( ($M+1)*$J, ($R+$M) ) * $V; $vardim{"2RV"} = 2 * $R * $V; $vardim{"2MP1JV"} = 2 * ($M+1) * $J * $V; $vardim{"NPMV"} = ($N+$M) * $V; $vardim{"TSLV"} = $TSL * $V; $vardim{"LRECV"} = ($I+1) * $L * (4+$NTRAC) * $V; $vardim{"XBIBJV"} = MAX( $BI, $BJ) * $V; $vardim{"LXBIBJV"} = $L * MAX( $BI, $BJ) * $V; my $OI = 769; my $OJ = 384; my $OL = 200; $vardim{"OI"} = $OI; $vardim{"OJ"} = $OJ; $vardim{"OIJ"} = $OI * $OJ; $vardim{"OIJV"} = $OI * $OJ * $V; $vardim{"OIP2"} = $OI + 2; $vardim{"OJP2"} = $OJ + 2; $vardim{"OIP2JP2"} = ($OI+2) * ($OJ+2); $vardim{"OIP2JP2V"} = ($OI+2) * ($OJ+2) * $V; $vardim{"OL"} = $OL; if ( $verbose > 10 ) { print "Variable dimension parameters:\n"; foreach (sort keys %vardim) { printf "%10s = %s\n",$_,$vardim{$_}; } } return 1; } sub wrap_ffixed_line { # Check that the input line does not exceed 72 characters # If it does then wrap it, assuming that is is fixed format fortran use strict; my $line = shift; # Do nothing if this line is empty or contains nothing but whitespace return $line if $line =~ /^\s*$/; # Do nothing if this is a comment line or a preprocessor line return $line if $line =~ /^[C#]/i; # The output line will be the input line unless it is modified below my $line_out = $line; # Check for a trailing newline and remove it if present my $has_nl = chomp($line_out); # $comm is a trailing "!" delimited comment, if any, on the current line # $fline is the current line with any trailing comment stripped my ($fline, $comm) = rm_comments_from_line( $line_out ); if ( length($fline) > 72 ) { my $part1 = substr($fline,0,72); my $part2 = substr($fline,73); $line_out = "$part1\n"; $line_out .= " &$part2 $comm"; } # Repalce the trailing newline if it was present on input $line_out .= "\n" if $has_nl; return $line_out; } sub find_files_in { # Find files recursively below a given directory # The first arg must be a directory name # All subsequent args are a list of file names to search for # If this file list is empty then return all regular files found # The output file list will always contain full pathnames use strict; use Cwd qw(abs_path); my $dir = shift; die "find_files_in requires a directory name as input.\n" unless $dir; die "find_files_in: Input directory --> $dir <-- does not exist.\n" unless -d "$dir"; # Determine if files are found recusrsively through all subdirs below this dir my $recurse = shift; $recurse = 1 unless defined $recurse; # Get a list of user supplied files or regexes # Only the basename part of the file path is used in this list my @usr_flist;; foreach (@_) { if ( m![\w/.-]+! ) { # Assume this is a file name my ($name, $path, $sfx) = fileparse("$_", ()); push @usr_flist, "$name$sfx"; } else { # This is likely a regex # Whatever it is, simply add it to the list push @usr_flist, $_; } } # Ensure a full pathname with no trailing "/" $dir = abs_path( $dir ); opendir DIR, $dir || die "Unable to open dir $dir $!"; # exclude all .* files, files ending with "~", files that begin with "tmp_" # as well as files named "RCS" or "CVS" # Order this list lexically my @files = sort grep {!/^\./ and !/~$/ and !/^tmp_/ and !/^RCS$/ and !/^CVS$/} readdir DIR; closedir DIR; # Get a list of full pathnames to sub dirs, if any my @dirs = grep {-d} map "$dir/$_", @files; # Determine which of these files to keep my @keep_files; foreach my $file ( @files ) { # Ignore anything that is not a regular file next unless -f "$dir/$file"; my @keep = (); if ( scalar(@usr_flist) ) { # The user has supplied a list of file names or regexs to # be used to filter the file names foreach ( @usr_flist ) { next unless $file =~ /^$_$/; push @keep, $file unless grep /^$file$/, @keep; } } else { # There is no user supplied list, keep every regular file push @keep, $file unless grep /^$file$/, @keep; } # Ensure full pathnames for each output file foreach (@keep) { my $fp = "$dir/$_"; $fp = abs_path( $fp ); push @keep_files, $fp unless grep /^$fp$/, @keep_files } } my @files_out = @keep_files; if ( $recurse ) { foreach ( @dirs ) { # Get files from all subdirs push @files_out, find_files_in($_, 1, @usr_flist); } } return @files_out; } sub find_dirs_in { # Find sub directories (possibly recursively) below a give directory use strict; use Cwd qw(abs_path); my $dir = shift; die "find_dirs_in requires a directory name as input.\n" unless $dir; # # Find # my ($name, $path, $sfx) = fileparse($dir, ()); # # if ( $name =~ m<(\Q*\E|\Q?\E|\Q[!\E|\Q[\E.*?\Q]\E)> ) { # # If the innermost directory name contains shell wildcards then expand this first # my @s = (); # my $path_part = ""; # foreach ( split( '/', $path ) { # push @paths, find_dirs_in( $path, 0 ); # } # } # # unless ( -d "$dir" ) { # # If this is not a directory then see if its parent is a dir # if ( -d $path ) { # } # } die "find_dirs_in: Input directory --> $dir <-- does not exist.\n" unless -d "$dir"; # Determine if files are found recusrsively through all subdirs below this dir my $recurse = shift; $recurse = 1 unless defined $recurse; $dir = abs_path( $dir ); opendir DIR, $dir || die "Unable to open dir $dir"; # exclude all .* files, files ending with "~", files that begin with "tmp_" # as well as files named "RCS" or "CVS" # Order this list lexically my @files = sort grep {!/^\./ and !/~$/ and !/^tmp_/ and !/^RCS$/ and !/^CVS$/} readdir DIR; closedir DIR; # Filter out all non-directory files and ensure a full pathname my @dirs = grep {-d} map abs_path("$dir/$_"), @files; my @dirs_out = @dirs; print "find_dirs_in: @dirs_out\n"; if ( $recurse ) { foreach ( @dirs ) { push @dirs_out, find_dirs_in($_, 1); } } return @dirs_out; } sub print_scan_info { # Print elements from the following variables that are populated when source files # are scanned to gather info that will be used to determine dependencies # %source { abspath } = actual source, after processing # %full_path { file_basename } = abspath ! absolute path to this file # %freefmt { file_basename } = 0 or 1 ! is this free format or fixed format # %is_main { file_basename } = 0 or 1 ! is this a main program or other # %is_target { file_basename } = 0 or 1 ! does this require a target in the makefile # %has_cppdefs{ file_basename } = 0 or 1 ! does this file contain cpp directives # %has_ddelim { file_basename } = 0 or 1 ! does this file contain "$" delimited text segments # %func_path { function_name } = abspath ! path to file containing this function # %sub_path { subroutine_name } = abspath ! path to file containing this subroutine # %mod_path { module_name } = abspath ! path to file containing this function use strict; my $verbose = shift; my $pfx = shift; $verbose = 0 unless $verbose; $pfx = "##" unless $pfx; printf "%s M = This file contains a main program\n",$pfx; printf "%s F = This file contains free format fortran source code\n",$pfx; printf "%s I = This is an \"included\" file, not compiled on its own\n",$pfx; printf "%s C = This file contains cpp directives\n",$pfx; printf "%s \$ = This file contains \"\$...\$\" delimited text segments\n",$pfx; printf "%s %30s %2s %2s %2s %2s %2s\n",$pfx," ","M","F","I","C","\$"; foreach my $bname ( sort keys %full_path ) { my $path = $full_path{$bname}; my $free = $freefmt{$bname} ? "T" : "F"; my $main = $is_main{$bname} ? "T" : "F"; my $targ = $is_target{$bname} ? "F" : "T"; my $wcpp = $has_cppdefs{$bname} ? "T" : "F"; my $wddl = $has_ddelim{$bname} ? "T" : "F"; printf "%s %30s %2s %2s %2s %2s %2s %s\n",$pfx,$bname,$main,$free,$targ,$wcpp,$wddl,$path; if ( $verbose > 1 ) { my @mod_list = (); foreach my $key ( sort keys %mod_path ) { # $mod_path{$key} is an absolute path name to the file containing this module my ($name, $path, $sfx) = fileparse($mod_path{$key}, ()); # $key is the name of the module push @mod_list, "$key" if "$name$sfx" eq $bname; } if ( scalar(@mod_list) ) { printf "%s ",$pfx; print " modules: ",join(" ", @mod_list),"\n"; } } if ( $verbose > 2 ) { my @func_list = (); foreach my $key ( sort keys %func_path ) { # $func_path{$key} is an absolute path name to the file containing this function my ($name, $path, $sfx) = fileparse($func_path{$key}, ()); # $key is the name of the function push @func_list, "$key" if "$name$sfx" eq $bname; } if ( scalar(@func_list) ) { printf "%s ",$pfx; print " functions: ",join(" ", @func_list),"\n"; } my @sub_list = (); foreach my $key ( sort keys %sub_path ) { # $sub_path{$key} is an absolute path name to the file containing this subroutine my ($name, $path, $sfx) = fileparse($sub_path{$key}, ()); # $key is the name of the subrotuine push @sub_list, "$key" if "$name$sfx" eq $bname; } if ( scalar(@sub_list) ) { printf "%s ",$pfx; print "subroutines: ",join(" ", @sub_list),"\n"; } } } return 1; } sub usage { my($err, $msg) = @_; $err = 0 unless defined $err; $msg = "" unless defined $msg; warn("$msg\n") if $msg; my $USAGE = <<'END_OF_USAGE'; Usage: cccmf [options|defs] file|flist=FLIST [file ...] Purpose: Create a Makefile to compile a fortran program The resulting make file must be used on the same machine it was created on All dependencies are determined and make targets are created for each dependency. Dependent files are searched for in the following order: 1) the directory from which cccmf was invoked 2) an optional user supplied list of directories 3) a standard CCRNSRC source tree, if modver=STRING is present 4) a standard ocean directory, if ocnver=STRING is present When model_job=STRING is supplied on the command line, the value of certain quatities will be affected if the relevant parmsub parameters are present. The potentially affected quatities are: omp, coupled, float1, float2, xlfqinitauto, xlfimp, p5lib, xlfversion, user_source Specifying any of these explicitly on the command line will over ride the value determined from parmsub parameters that were found in the model job, if any. Options: # All options except help and verbose may be preceeded by "no" to negate their meaning --x ..Execute make after this program finishes, using the make file created here --omp ..Link with OpenMP libraries and include dirs --mpi ..Link with MPI libraries and include dirs --netcdf ..Link with netcdf libraries and include dirs --coupled ..Include coupled model specific code --float1 ..Use the float1 option, 4 byte real and integer (only meaningful with CCCma default compiler) --float2 ..Use the float2 option, 8 byte real and integer (only meaningful with CCCma default compiler) --xlfqinitauto ..Used to identify a specific variant of a compiled library and to filter the xlf command line accordingly (only meaningful with CCCma default compiler on aix) --xlfimp ..Use the -qflttrap=imprecise option on the xlf compler command line (only meaningful with CCCma default compiler on aix) --xlflarge ..Add some options to the xlf command line that will set page size to 64K (only meaningful with CCCma default compiler on aix) --p5lib ..Use certain libraries from the P5 (only meaningful with CCCma default compiler on aix) --wcache ..Force creation of the cache file --pcache ..Print info from the cache file to stdout --help ..Display this help and exit --verbose ..Increase verbosity (additive) Definitions: flist=STRING ...The name of a text file containing file names to be compiled There should be one file name per line. Only the first whitespace separated word on each line is used as the file name. Blank lines and comment lines (lines whose first non-whitespace character is "#") are ignored. The files in this list will be processed after any files whose names appear separately on the command line. make_file=STRING ...The name of the output make file (default "Makefile") make_inc=STRING ...The name of a file to be included in the output makefile This should contain makefile commands and definitions which will override internal macros of the same name path=LIST ...A list of additional directories in which source files may be found. These dirs will be searched for files before any internally defined paths are searched target=STRING ...A white space separated list of target names to use in the make file This will be the names of program executables (files containing a "program ..." line) that are created when the make file is run. Typically there will be only one main program to be compiled but multiple main programs are supported. If target is not supplied on the command line then the name of the file containing the main program (without any ".f", ".F", ".dk", etc suffix) is used. These user supplied names are used in order until they are exhausted, then any remaining target names default to the file name. modver=STRING ...AGCM model version (e.g. gcm16, gcm17, ...) ocnver=STRING ...OGCM model version (e.g. CanESM4.1, CanESM4.2, ...) ocndir=STRING ...The name of a directory into which ocean source will be copied (default ./local_ocnsrc) updates=STRING ...The name of a file containing updates If updates are provided (either via updates or model_job on the command line) then process these updates and put any modified files into the invoking dir. These modified files will then be compiled, instead of the files from which they were derived, when make is run. cppdefs=STRING ...The name of a file containing cpp directives, typically "#define ..." This file will be included at the top of all files that contain cpp directives. This file will usually contain what appears in the CPP_I section of a model job string, but may contain any cpp directives. sizes=STRING ...The name of a file containing definitions of the form VAR = VALUE with one definition per line. Wherever a string of the form $VAR$ is found in any source file it will be replaced with VALUE. This is typically only found in AGCM "lsmod" routines. model_job=STRING ...The name of a file containing a model job. This may be used in place of updates=STRING and/or cppdefs=STRING and/or sizes=STRING. Information about updates, cppdefs and sizes will be extracted from the user supplied model job string, if it is present therein. If any of updates, cppdefs or sizes are supplied on the command line along with model_job then the information in the updates, cppdefs or sizes file will be used instead of that found in the model_job file. cache=STRING ...Name of file to be used as a cache for CCRNSRC dependency info This file is created if it does not already exist and overwritten if it does exist. Normally a default name is used for this file but that name may be changed by the user via atm_cache=STRING cache_only=STRING ...This is the same as cache except that once the cache file is created the program stops. No make file is created. This is typically used only in cron jobs to create system cache files but users may find other uses exclude=STRING ...A space separated list of file or directory names to exclude when testing for dependencies. For file names these will be just the basename part of the file name (e.g. abc.f, xyz.dk, etc). Directory names are distinguished by having a trailing "/" appended to them (e.g. "dirname/"). Multiple exclude defs are cumulative. verbose=Int ...Set verbosity flag to any integer (this will override --verbose) FC=STRING ...The name of the fortran compiler to be used FFLAGS=STRING ...Compiler command line options (white space must be quoted) If neither FC nor FFLAGS are set on the command line then a default compile line will be used in the make file created by cccmf. The default will be that found in the F77_float2 environment variable. This default may be modified by certain user supplied args which are identified within the scope of this documentation (e.g. --float1, --omp, --mpi, --xlfqinitauto, --xlfimp, --xlflarge, --p5lib, etc). LIBS=STRING ...The command line options required by FC to identify libraries This will usually be something like "-L/path/to/libs -lnameA -lnameB". LIBS defined on the command line will be prepended to LIBS defined internally. This string is passed directly to the linker in the make file. The special case of LIBS="none" will add nothing to the link line. The special case of LIBS="system" will add only system libs. Using LIBS="none" or LIBS="system" (or defining FC or FFLAGS) will cause cccmf to create a make file that will compile every dependency as well as the main targets since there will be no model libraries used. INCS=STRING ...The command line options required by FC to identify include dirs This will usually be something like "-I/path/to/include -I/another/path". INCS defined on the command line will be prepended to INCS defined internally. This string is passed directly to relevant complie lines in the make file. xlfversion=STRING ...This may be used to identify a specific variant of a compiled library Currently the only allowable values are: xlf12104, xlf13108, xlf14101. If not set on the command line and model_job is supplied then, if the parmsub section of that model job contains a parameter named xlf12104, xlf13108 or xlf14101 and its value is "on", xlfversion will be set accordingly. This is only meaninful when the default compiler is used (ie neither FC nor FFLAGS is set by the user). user_source=STRING ..This will be the name of a directory containing user supplied ocean source which will overwrite any ocean source files of the same name that are found in the version specific ocean source dir. Version specific ocean source is determined by setting ocnver on the command line. If the user does not supply user_source on the command line but does supply model_job, and user_source is defined in that model job, then the value found in the model job will be used. END_OF_USAGE print $USAGE; exit($err); } sub syscmd { use strict; my $cmd = shift; my $show_stdout = shift; my $stop_on_error = shift; die "Missing system command string\n" unless $cmd; $stop_on_error = 1 unless defined $stop_on_error; if ( $verbose > 1 ) { print "$cmd\n"; } chomp(my @sh_out = `$cmd 2>&1`); my $sh_err = $?; if ( $show_stdout or $sh_err ) { foreach (@sh_out) {print "$_\n"} } if ( $stop_on_error and $sh_err ) { die "** EE ** Problem executing\n $cmd\n"; } # Return command stdout in array context, otherwise return command status return wantarray ? @sh_out : $sh_err; } sub ensure_trailing_slash { use strict; # Ensure there is a trailing slash on a string # The global variable $/ is the input record separator (default newline) # Set it to "/" for the duration of this subroutine so # that chomp will strip any trailing "/". local $/ = '/'; chomp $_[0]; $_[0] .= '/'; } sub get_ocn_src { use strict; my $ocnver = shift; my $ocndir = shift; my $user_source = shift; die "get_ocn_src: No ocean source version was supplied.\n" unless $ocnver; die "get_ocn_src: No ocean directory was supplied.\n" unless $ocndir; # A subdir, relative to the root of the repo, in which the ocean source lives my $ocn_src_root = "src/ocean/canesm"; # The --prefix arg to git archive should have a trailing slash so that # it will be treated as a top level directory my $tmpd = "tmp_$ocndir"; ensure_trailing_slash($tmpd); my $cmd = "$GIT archive --remote=$ocn_src_repo --format=tar --prefix=$tmpd $ocnver $ocn_src_root|tar xf -"; my $err = syscmd( $cmd, 0, 0 ); if ( $err ) { my @sh_out = syscmd( "cd $ocn_src_repo; $GIT tag" ); print "Valid tags for ocean model version are:\n"; foreach (@sh_out) {print "\t$_\n"} die "** EE ** Problem executing\n $cmd\n"; } if ( not -d $ocndir ) { # Create ocndir if it does not already exist syscmd( "mkdir $ocndir" ); } else { # Otherwise remove everthing in ocndir syscmd( "rm -fr $ocndir/*" ); } # Remove the ocn_src_root stem from this path $cmd = "mv $tmpd/$ocn_src_root/* $ocndir && rm -fr $tmpd"; syscmd( $cmd ); # Ensure all ocean source code is user writeable chmod 0644, glob("$ocndir/*"); # Copy files from a user supplied directory and overwrite existing files in ocndir if ( $user_source ) { # The user may supply a value of "none" for user_source to override any value # that happens to be set in the parmsub section of the model_job input file unless ( $user_source eq "none" ) { # The user has supplied a directory name on the comand line die "user_source = $user_source is not a directory.\n" unless -d $user_source; print "Overwriting $ocnver ocean source with files found in $user_source\n"; if ( $verbose > 0 ) { print "\t",join("\n\t",glob("$user_source/*")),"\n"; } syscmd( "cp -f $user_source/* $ocndir/" ); } } # Make changes to certain ocean source files to allow use of the fortran # preprocessor and fix a few coding "quirks" that can cause other problems my $file = ""; # Modify cpl_driver.F if it exists $file = "$ocndir/cpl_driver.F"; if ( -s $file and $ocnver eq "CanESM4.1" ) { # Remove dependence on the __FILE__ macro since this sometimes causes # problems with the preprocessor (ie lines longer then 72 chars) my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); if ( $fsrc =~ m@__FILE__@ ) { # Replace the first (and only) occurrence of the __FILE__ macro in this file $fsrc =~ s@\scaller_file_name\s*=\s*&\s*__FILE__[^\n]*\n@ caller_file_name = "cpl_driver.F"\n@s; # Overwrite the existing file with this modified code open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Modify cpl_read_spec_bc.F if it exists $file = "$ocndir/cpl_read_spec_bc.F"; if ( -s $file and $ocnver eq "CanESM4.1" ) { # Remove dependence on the __FILE__ macro since this sometimes causes # problems with the preprocessor (ie lines longer then 72 chars) my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); if ( $fsrc =~ m@__FILE__@ ) { # Replace the first (and only) occurrence of the __FILE__ macro in this file $fsrc =~ s@\scaller_file_name\s*=\s*&\s*__FILE__[^\n]*\n@ caller_file_name = "cpl_read_spec_bc.F"\n@s; # Overwrite the existing file with this modified code open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Modify ctem_read_fld.F if it exists $file = "$ocndir/ctem_read_fld.F"; if ( -s $file and $ocnver eq "CanESM4.1" ) { # Remove dependence on the __FILE__ macro since this sometimes causes # problems with the preprocessor (ie lines longer then 72 chars) my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); if ( $fsrc =~ m@__FILE__@ ) { # Replace the first (and only) occurrence of the __FILE__ macro in this file $fsrc =~ s@\scaller_file_name\s*=\s*&\s*__FILE__[^\n]*\n@ caller_file_name = "ctem_read_fld.F"\n@s; # Overwrite the existing file with this modified code open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Modify ctem_write_fld.F if it exists $file = "$ocndir/ctem_write_fld.F"; if ( -s $file and $ocnver eq "CanESM4.1" ) { # Remove dependence on the __FILE__ macro since this sometimes causes # problems with the preprocessor (ie lines longer then 72 chars) my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); if ( $fsrc =~ m@__FILE__@ ) { # Replace the first (and only) occurrence of the __FILE__ macro in this file $fsrc =~ s@\scaller_file_name\s*=\s*&\s*__FILE__[^\n]*\n@ caller_file_name = "ctem_write_fld.F"\n@s; # Overwrite the existing file with this modified code open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Modify sflx3_bio.F if it exists $file = "$ocndir/sflx3_bio.F"; if ( -s $file and $ocnver eq "CanESM4.1" ) { # This file has an unmatched "return\s*end" pair of lines # as the last 2 lines in the file. # This results in an extra "main" program that has only 2 lines # (and it will do nothing) but it may cause a load error my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); if ( $fsrc =~ s@(\n#\s*endif[^\n]*)\s*return\s*end\s*$@$1\n@s ) { # Overwrite the existing file with this modified code open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # The following changes will be applied to all ocean source files with a ".F" suffix foreach my $file ( glob("$ocndir/*.F") ) { my $fsrc = ""; open(FTMP, "<$file") or die "$! Stopped"; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FTMP); # Use a flag to determine if any changes were made my $change = 0; # Remove any /* ... */ comments # Removing these C style comments will allow the fortran preprocessor to be used $change=1 if $fsrc =~ s@^(.*)\s*/\*.*\*/[ \t]*$@$1@mg; # Remove the last char from fortran comment lines that end with "\" # The back slash is the cpp continuation character and these lines # will be joined with the following line after preprocessing. # This is a problem when the following line is a valid fortan source line # since this will effectively comment out that valid source line. $change=1 if $fsrc =~ s@((?:^|\n)[cC!][^\n]*)\\\n@$1\n@sg; # Remove whitespace from the beginning of lines that start with "#" # These will be preprocessor lines and, although some compilers will allow this, # it is an error for a preprocessor line to not have "#" as the first character $change=1 if $fsrc =~ s@(^|\n)[ \t]+#@$1#@sg; # Remove the last char from preprocessor lines that end with "\" # and concatenate these lines with the next line # The fortran preprocessor will (possibly) ignore these continuation lines # (possibly emitting an error about expecting a new-line character on a directive) # Such continuaiton lines may result in unexpected inclusion/exclusion of conditional # code when the fortran preprocessor is used, so we concatenate them to be safe while ( $fsrc =~ s@((?:^|\n)#[^\n]*?)[ \t]*\\\n[ \t]*([^\n]*\n)@$1 $2@sg ) { # Do this in a loop to catch multiple consecutive continuation lines $change=1; } if ( $change ) { # Overwrite the existing file with this modified code if ( $verbose > 10 ) { open(FTMP, ">${file}_new") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); print "\n*** Modified $file\n"; syscmd( "diff -b $file ${file}_new", 1, 0 ); syscmd( "rm -f ${file}_new" ); } open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Replace Holerith strings and fix certain function calls, as required foreach my $file ( glob("$ocndir/*.F") ) { # Filter the source in this file to fix some quirks in legacy code my ($fsrc, $change) = filter_src_file( $file ); if ( $change ) { # If the file was changed then overwrite the existing version open(FTMP, ">$file") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); } } # Ensure all ocean source code is world readable syscmd( "chmod a+r $ocndir/*" ); return 1; } sub filter_src_file { # Filter the input file to: # - replace Holerith strings 4H.... with nc4to8("....") # - replace function name "LNBLNK" with "LEN_TRIM" # - replace function name "CVMGT" with "MERGE" # - replace function name "AIMAG(" with "IMAG(" # - replace "VR IMAG" with "VRIMAG" # - replace "ACCESS=APPEND" with "POSITION=APPEND" # - wrap lines that grow longer than 72 chars due to these changes use strict; my $file = shift; my $fsrc_in = shift; my $fsrc = ""; unless ( $fsrc_in ) { # Get a copy of the contents of the input file unless this was provided # by the user via $fsrc_in in the input parameter list die "filter_src_file: Missing file name.\n" unless $file; open(FTMP, "<$file") or die "Unable to read file $file $!\n"; # expand tabs as each line is read while () {$fsrc_in .= expand($_)}; close(FTMP); } # Write a sed program and then pipe the output from running that program # on the input file into a local variable my $sed_prog = '/^[Cc#%]/b /^ DATA/b /^ [Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn] *[Ll][Nn][Bb][Ll][Nn][Kk]/b /^ [Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn] *[Cc][Vv][Mm][Gg][TtPp]/b /\/ *4H/b /[^ ,.=\/]4H/b /AIMAG\( *(\)/s// IMAG\1/g /VR IMAG/s//VRAIMAG/g /4H..../{ s/4H\(....\)/NC4TO8("\1")/g s/ *$//g /^.\{73,\}/s/^\(.\{72\}\)\(.*\)/\1\ +\2/ } /[Aa][Cc][Cc][Ee][Ss][Ss]=.[Aa][Pp][Pp][Ee][Nn][Dd]./{ s/[Aa][Cc][Cc][Ee][Ss][Ss]/POSITION/g s/ *$//g /^.\{73,\}/s/^\(.\{72\}\)\(.*\)/\1\ +\2/ } /[Cc][Vv][Mm][Gg][Tt]/{ s/[Cc][Vv][Mm][Gg][Tt] *(/MERGE(/g } /[Ll][Nn][Bb][Ll][Nn][Kk]/{ s/[Ll][Nn][Bb][Ll][Nn][Kk]/LEN_TRIM/g /^.\{73,\}/s/^\(.\{72\}\)\(.*\)/\1\ +\2/ }'; open(SED_FILE, "sed \'$sed_prog\' $file|") or die "$! Stopped"; while () { $fsrc .= "$_" }; close(SED_FILE); # Set a flag to indicate if the file was changed my $change = not($fsrc_in eq $fsrc); if ( $change and $verbose > 10 ) { open(FTMP, ">${file}_new") or die "$! Stopped"; print FTMP $fsrc; close(FTMP); print "\n*** Changed $file\n"; syscmd( "diff -b $file ${file}_new", 1, 0 ); syscmd( "rm -f ${file}_new" ); } return wantarray ? ($fsrc, $change) : $fsrc; } sub read_cache { use strict; my $cache_file = shift; die "read_cache: Missing cache file name.\n" unless $cache_file; die "read_cache: Missing or empty cache file $cache_file\n" unless -s $cache_file; # Read hash info from a "Storeable" file in the same order that it was written open(CACHE, "<$cache_file") or die "** EE ** Opening ${cache_file}: $!\n"; my $source_href = fd_retrieve(*CACHE); my $func_path_href = fd_retrieve(*CACHE); my $sub_path_href = fd_retrieve(*CACHE); my $mod_path_href = fd_retrieve(*CACHE); my $freefmt_href = fd_retrieve(*CACHE); my $is_main_href = fd_retrieve(*CACHE); my $is_target_href = fd_retrieve(*CACHE); my $full_path_href = fd_retrieve(*CACHE); my $has_cppdefs_href = fd_retrieve(*CACHE); my $has_ddelim_href = fd_retrieve(*CACHE); my $contains_mod_href = fd_retrieve(*CACHE); my $uses_mod_href = fd_retrieve(*CACHE); close(CACHE); # Assign values read from the file to global hash keys unless # the in memory versions already contain defs for these keys foreach my $key ( keys %{$source_href} ) { # Add this key to the current hash unless one already exists $source{$key} = $source_href->{$key} unless $source{$key}; } foreach my $key ( keys %{$func_path_href} ) { # Add this key to the current hash unless one already exists $func_path{$key} = $func_path_href->{$key} unless $func_path{$key}; } foreach my $key ( keys %{$sub_path_href} ) { # Add this key to the current hash unless one already exists $sub_path{$key} = $sub_path_href->{$key} unless $sub_path{$key}; } foreach my $key ( keys %{$mod_path_href} ) { # Add this key to the current hash unless one already exists $mod_path{$key} = $mod_path_href->{$key} unless $mod_path{$key}; } foreach my $key ( keys %{$freefmt_href} ) { # Add this key to the current hash unless one already exists $freefmt{$key} = $freefmt_href->{$key} unless $freefmt{$key}; } foreach my $key ( keys %{$is_main_href} ) { # Add this key to the current hash unless one already exists $is_main{$key} = $is_main_href->{$key} unless $is_main{$key}; } foreach my $key ( keys %{$is_target_href} ) { # Add this key to the current hash unless one already exists $is_target{$key} = $is_target_href->{$key} unless $is_target{$key}; } foreach my $key ( keys %{$full_path_href} ) { # Add this key to the current hash unless one already exists $full_path{$key} = $full_path_href->{$key} unless $full_path{$key}; } foreach my $key ( keys %{$has_cppdefs_href} ) { # Add this key to the current hash unless one already exists $has_cppdefs{$key} = $has_cppdefs_href->{$key} unless $has_cppdefs{$key}; } foreach my $key ( keys %{$has_ddelim_href} ) { # Add this key to the current hash unless one already exists $has_ddelim{$key} = $has_ddelim_href->{$key} unless $has_ddelim{$key}; } foreach my $key ( keys %{$contains_mod_href} ) { # Add this key to the current hash unless one already exists $contains_mod{$key} = $contains_mod_href->{$key} unless $contains_mod{$key}; } foreach my $key ( keys %{$uses_mod_href} ) { # Add this key to the current hash unless one already exists $uses_mod{$key} = $uses_mod_href->{$key} unless $uses_mod{$key}; } return 1; } sub print_cache { use strict; my $cache_file = shift; die "print_cache: Missing cache file name.\n" unless $cache_file; die "print_cache: Missing or empty cache file $cache_file\n" unless -s $cache_file; # The cache file contains the following entities # %source { abspath } = actual source, after processing # %full_path { file_basename } = abspath ! absolute path to this file # %freefmt { file_basename } = 0 or 1 ! is this free format or fixed format # %is_main { file_basename } = 0 or 1 ! is this a main program or other # %is_target { file_basename } = 0 or 1 ! does this require a target in the makefile # %has_cppdefs { file_basename } = 0 or 1 ! does this file contain cpp directives # %has_ddelim { file_basename } = 0 or 1 ! does this file contain "$" delimited text # %contains_mod { file_basename } = 0 or 1 ! does this file contain modules # %uses_mod { file_basename } = 0 or 1 ! does this file use modules # %func_path { function_name } = abspath ! path to file containing this function # %sub_path { subroutine_name } = abspath ! path to file containing this subroutine # %mod_path { module_name } = abspath ! path to file containing this function # The full_path hash should contain the names of all files found in the cache print "\n"; printf "1) %s\n","is a main program"; printf "2) %s\n","source is free format"; printf "3) %s\n","contains modules"; printf "4) %s\n","uses modules"; printf "5) %s\n","contains cpp directives"; printf "6) %s\n","contains '\$' delimited text"; printf "7) %s\n","can be a target to compile"; printf "\n%30s %2s%2s%2s%2s%2s%2s%2s %s\n", "File Name",'1','2','3','4','5','6','7','Full path name'; printf "%30s %14s %s\n","-" x 30,"-" x 13,"-" x 45; foreach my $fname ( sort keys %full_path ) { printf "%30s %2s%2s%2s%2s%2s%2s%2s %s\n", $fname, $is_main{$fname} ? "T" : "F", $freefmt{$fname} ? "T" : "F", $contains_mod{$fname} ? "T" : "F", $uses_mod{$fname} ? "T" : "F", $has_cppdefs{$fname} ? "T" : "F", $has_ddelim{$fname} ? "T" : "F", $is_target{$fname} ? "T" : "F", $full_path{$fname}; } if (scalar(keys %sub_path)) { printf "\n%30s %s\n","Subroutine name","Path to file containing subroutine source"; printf "%30s %s\n","-" x 30,"-" x 45; foreach my $proc ( sort keys %sub_path ) { printf "%30s %s\n",$proc,$sub_path{$proc}; } } if (scalar(keys %func_path)) { printf "\n%30s %s\n","Function name","Path to file containing function source"; printf "%30s %s\n","-" x 30,"-" x 45; foreach my $proc ( sort keys %func_path ) { printf "%30s %s\n",$proc,$func_path{$proc}; } } if (scalar(keys %mod_path)) { printf "\n%30s %s\n","Module name","Path to file containing module source"; printf "%30s %s\n","-" x 30,"-" x 45; foreach my $proc ( sort keys %mod_path ) { printf "%30s %s\n",$proc,$mod_path{$proc}; } } return 1; } sub write_makefile { use strict; my $make_file = shift; my $flist_aref = shift; my $all_target = "\$(PROJ_LIB)"; foreach my $fname ( @{$flist_aref} ) { my ($bname, $path, $sfx) = fileparse("$fname", @suffix_list); unless ($sfx) { die "write_makefile: Missing or invalid suffix for file $fname\n"; } # Do not include this with the "all" target unless it is itself a target next unless $is_target{"$bname$sfx"}; if ( $is_main{"$bname$sfx"} ) { # This is a main program and will be created as bname (this may change) my $target_name = $bname; if ( scalar(@main_targets) ) { # If the user has supplied a list of target names, they are assigned to @main_targets # Use these names in order until they are exhausted, then default to the file name # for the name of the target as it appears in the make file $target_name = shift @main_targets; } $all_target .= " $target_name"; $main_target_name{$bname} = "$target_name"; } else { # This is a non-main target, assume a ".o" file $all_target .= " $bname.o"; } } open(MAKEFILE, ">$make_file") or die "** EE ** Opening ${make_file}: $!\n"; chomp(my $just_now=`date`); my ($real_name) = split ',',(getpwuid($<))[6]; print MAKEFILE "# Created $just_now by $real_name using $Runame with the following options:\n"; print MAKEFILE "# $Runame $cmd_line\n\n"; print MAKEFILE "# Makefile to compile:\n# ",join("\n# ",@flist),"\n"; print MAKEFILE "\n# *** Requires GNU make ***\n\n"; # Build components print MAKEFILE "build_agcm := ",$build_agcm,"\n"; print MAKEFILE "build_coupler := ",$build_coupler,"\n"; print MAKEFILE << 'EOF_MAKFILE'; # Define a string to append to file names etc STAMP := $(shell date "+%Y_%b_%d_%H%M%S_$$$$") # The root of the acrnopt package directory OPT_ROOT := $(shell perl -e '$$x=(getpwnam "acrnopt")[7]."/package"; print $$x if -d $$x' 2>/dev/null) ifndef OPT_ROOT OPT_ROOT := $(shell perl -e '$$x=(getpwnam "scrd102")[7]."/package"; print $$x if -d $$x' 2>/dev/null) endif ifndef OPT_ROOT $(warning OPT_ROOT is not defined.) endif # Define a string to identify the kernel/hardware type os=$(shell uname -s 2>/dev/null) hw=$(shell uname -m 2>/dev/null) ifeq ($(strip $(os)-$(hw)),Linux-x86_64) ARCH := linux64 else ifeq ($(strip $(os)),AIX) ARCH := aix64 else $(error Unrecognized architecture $(os) $(hw)) endif undefine os undefine hw # Determine kernel type and machine name MACH_TYPE := $(shell uname -s|tr '[A-Z]' '[a-z]') MACH_NAME := $(word 1,$(subst ., ,$(shell uname -n|awk -F'.' '{print $1}' -))) ifeq ($(MACH_TYPE), linux) # Determine dns domain name DOMAIN := $(subst int.cmc.,cmc.,$(shell dnsdomainname)) endif ifeq ($(MACH_TYPE), aix) # Determine dns domain name DOMAIN := $(subst int.cmc.,cmc.,$(word 2,$(shell grep -E 'search|domain' /etc/resolv.conf))) endif # Determine location, typically either cccma or cmc # Knowing location is useful for setting lib paths etc LOCATION := $(word 1,$(subst ., ,$(DOMAIN))) EOF_MAKFILE if ( $proj_lib ) { print MAKEFILE "# The name of a project specific local archive library\n"; print MAKEFILE "PROJ_LIB := lib${proj_lib}.a\n"; } if ( $cppdefs_file ) { print MAKEFILE "cppdefs := $cppdefs_file\n\n"; } print MAKEFILE << 'EOF_MAKFILE'; ifdef cppdefs # If the user has supplied a value for cppdefs on the command line then use it # Verify that cppdefs exists ifneq ($(cppdefs),$(wildcard $(cppdefs))) $(error cppdefs=$(cppdefs) does not exist) endif else # Otherwise use CPP_I if a file by that name exists cppdefs := $(wildcard CPP_I) endif EOF_MAKFILE if ( $set_by_usr{cppdefs} ) { # This sould only appear when the user has supplied the cppdefs file on the command line print MAKEFILE << 'EOF_MAKFILE'; # If cppdefs is defined then preprocess the user supplied cppdefs file to remove lines # that do not begin with "#" and put the resulting file into the current directory. # These extra line are problematic when free format F90 source code is used and the # cppdefs file contains fixed format fortran comments or visa versa # This assumes that all fortran source lines found in cppdefs are comments ifdef cppdefs # Prefix the user supplied name with STAMP to get the local name local_cppdefs := $(join $(join $(STAMP),_),$(notdir $(cppdefs))) # Make cppdefs into an absolute path name override cppdefs := $(abspath $(cppdefs)) $(info cppdefs = $(cppdefs)) $(info local_cppdefs = $(local_cppdefs)) # Use sed to strip non-directives from the cppdefs file exit_status_file := tmp_exit_status_sed_cppdefs_$(STAMP) $(shell sed -n '/^#/p' $(cppdefs) > $(local_cppdefs); echo $$? > $(exit_status_file)) exit_status := $(shell cat $(exit_status_file); rm -f $(exit_status_file)) ifneq ($(strip $(exit_status)),0) $(error Problem creating local cppdefs file $(local_cppdefs)) endif endif EOF_MAKFILE } # print MAKEFILE "ifndef MODVER\n"; # print MAKEFILE " # Set a default value for MODVER when modver is not supplied by the user\n"; # if ( $parmsub{modver} ) { # print MAKEFILE " MODVER := $parmsub{modver}\n"; # } else { # print MAKEFILE " MODVER := gcm\n"; # print MAKEFILE " $(warning modver is not defined. Using modver = $(MODVER))\n"; # } # print MAKEFILE "endif\n"; # Create defs for vpath if ( $set_by_usr{atmver} or $set_by_usr{modver} or $set_by_usr{ocnver} ) { print MAKEFILE "\n# Tell make where to look for certain files when they are not in ./\n"; } if ( $CCRNSRC and ($set_by_usr{atmver} or $set_by_usr{modver}) ) { # Add a vpath entry that will cause make to look in the lsmod dir for ".cdk" files print MAKEFILE "vpath %.dk $CCRNSRC/source/lsmod/agcm/$atmver\n"; print MAKEFILE "vpath %.cdk $CCRNSRC/source/lsmod/agcm/$atmver\n"; } if ( $set_by_usr{ocnver} ) { # Add a vpath entry that will cause make to look in the ocean dir for ".h" files print MAKEFILE "vpath %.h $ocndir\n"; } # Define the compiler and compiler flags print MAKEFILE << 'EOF_MAKFILE'; # This needs to be modified so that output is never emitted from the module list command MOD_EXISTS := $(shell module list 2>/dev/null && echo 1) # Set the fortran compiler name and compiler flags # Remove any options that determine source format (e.g. "-qfixed=72" and "-qfree=f90" when using xlf) # Source format is pre-determined for each file and rules are written to use the FIXED or FREE macros defined below EOF_MAKFILE if ( @{$usrvar{prgenv}}[0] ) { print MAKEFILE "ifdef MOD_EXISTS\n"; print MAKEFILE " PRGENV := @{$usrvar{prgenv}}[0]\n"; print MAKEFILE "endif\n"; } else { print MAKEFILE "ifdef MOD_EXISTS\n"; print MAKEFILE ' PRGENV := $(shell module list 2>&1|grep PrgEnv|sed ',"'",'s/^.*PrgEnv-//; s/\/.*//',"'",')',"\n"; print MAKEFILE ' $(info Using the $(PRGENV) programming environment)',"\n"; print MAKEFILE ' cray_mpich := $(shell test -z "$(module list 2>&1|grep cray-mpich/)" && echo 1)',"\n"; print MAKEFILE ' $(info cray_mpich = (cray_mpich))',"\n"; print MAKEFILE "endif\n"; } # Define a string that will hold the name of a shell variable that will # expand to a complier command line in the users environment when the # makefile created here is invoked by that user if ( !$with{float1} and !$with{float2} ) { # Set the default to float2 if neither float1 nor float2 are true $with{float2} = 1; } my $envF77 = ""; # Also define a suffix that will be used to form library names below my $libsfx = 'float2'; if ($with{float1}) { if ($with{omp}) { $envF77 = $ENV{F77_float1_openmp}; warn "F77_float1_openmp is not defined in your environment.\n" unless $envF77; $libsfx = 'float1_openmp'; } else { $envF77 = $ENV{F77_float1}; warn "F77_float1 is not defined in your environment.\n" unless $envF77; $libsfx = 'float1'; } } else { if ($with{omp}) { $envF77 = $ENV{F77_openmp}; warn "F77_openmp is not defined in your environment.\n" unless $envF77; $libsfx = 'openmp'; } else { $envF77 = $ENV{F77_float2}; warn "F77_float2 is not defined in your environment.\n" unless $envF77; $libsfx = 'float2'; } } if ( $usr_FC ) { # This is non-fatal if the user has supplied a compiler name # warn "Unable to identify a default Fortran compiler. Using $usr_FC\n" unless $envF77; $envF77 = " "; } else { die "Unable to identify a default Fortran compiler and no compiler name was provided by the user.\n" unless $envF77; } # Define a procedure to remove a word beginning with a user supplied prefix # from a ":" separated list of words also supplied by the user # This is used to modify xlf compiler options in some cases my $strip_opt = sub{ my $pfx = shift; my $str=shift; # Note this is a case insensitive match $str =~ s/(:$pfx\w*|$pfx\w*:)//ig; if ( $str =~ s/($pfx\w*)//ig ) { # If $pfx is the only member of the list then return an empty string return undef; } else { # Otherwise return the possibly modified input string return $str; } }; # Determine compiler name and compiler flags from the current env my ($def_FC, $def_FFLAGS) = split(/\s+/,$envF77,2); # The name of the compiler to be used in the make file is in $FC my $FC = $usr_FC ? $usr_FC : $def_FC; die "Unable to identify a Fortran compiler name.\n" unless $FC; # The command line options to be used in the make file are in $FFLAGS my $FFLAGS = $usr_FFLAGS ? $usr_FFLAGS : $def_FFLAGS; if ( $with{mpi} or $with{coupled} ) { # Using mpi # If this is the xlf compiler then prefix it with "mp", if required substr($FC,0,0) = "mp" if $FC =~ /^\s*xlf/; } # Remove compiler options that determine free or fixed format # These will be added on a per target basis $FFLAGS =~ s/(-fixed|-free|-Mfixed|-Mfree|-ffixed-form|-ffree-form|-qfixed(=\w+)?|-qfree(=\w+)?)//g; if ( $FC =~ /^\s*(mp)?xlf/ ) { # This is the xlf compiler unless ( $with{xlfqinitauto} ) { # Add this if the user has invoked cccmf with the --noxlfqinitauto option $libsfx .= '_noxlfqinitauto'; # Remove the -qinitauto=... option from the compler command line, if any $FFLAGS =~ s/-qinitauto(=\w+)?//g; # Remove the -qfloat=nans option from the compler command line, if any $FFLAGS =~ s/(-qfloat=[:\w]+)/&$strip_opt("nans",$1)/eg; # Remove the -qflttrap=nanq option from the compler command line, if any $FFLAGS =~ s/(-qflttrap=[:\w]+)/&$strip_opt("nanq",$1)/eg; } unless ( $with{xlfimp} ) { # Remove the -qflttrap=imprecise option from the compler command line, if any $FFLAGS =~ s/(-qflttrap=[:\w]+)/&$strip_opt("imp",$1)/eg; } if ( $with{xlfversion} ) { # Add this if the user has supplied a def for the version of xlf $libsfx .= "_$with{xlfversion}"; } # Move the -bnoquiet compiler option to the end of the command line, if present $FFLAGS .= " -bnoquiet" if $FFLAGS =~ s/-bnoquiet/ /g; if ( $with{xlflarge} ) { # Add some ld options to the xlf command line that will set page size to 64K, namely # -bdatapsize:64K -bstackpsize:64K -btextpsize:64K $FFLAGS =~ s/(-bdatapsize:64K|-bstackpsize:64K|-btextpsize:64K)//g; $FFLAGS .= " -bdatapsize:64K -bstackpsize:64K -btextpsize:64K"; } } # Add an option that will return the source listing from the compiler if ( $FC =~ /^\s*(mp)?xlf/ ) { # Assume the xlf compiler $FFLAGS .= " -qsource"; } elsif ( $FC =~ /^\s*(mp)?pgf/ ) { # Assume the Portland Group compiler $FFLAGS .= " -Mlist"; #TODO } elsif ( $FC =~ /^\s*(mp)?gfo/ ) { #TODO # Assume GNU fortran compiler #TODO $FFLAGS .= " ???"; } # Replace multiple spaces with a single space $FFLAGS =~ s/\s+/ /g; if ( $usr_FC ) { # The user has supplied the name of the compiler on the command line print MAKEFILE "FC := $FC\n"; if ( $usr_FFLAGS ) { # Add the user supplied flags print MAKEFILE "FFLAGS := $FFLAGS\n"; } else { # supply no flags (use system defaults) print MAKEFILE "FFLAGS := \n"; } } else { # Use the default compiler name # The user may supply compiler flags, if not use the default FFLAGS print MAKEFILE "FC := $FC\n"; print MAKEFILE "FFLAGS := $FFLAGS\n"; } # Define AR and options for the current compiler my $arflags = "-r"; if ( $FC =~ /^\s*(mp)?xlf/ ) { if ($with{float1}) { $arflags = "-r -X64"; } else { $arflags = "-r -X64"; } } print MAKEFILE "\n"; print MAKEFILE "AR := ar\n"; print MAKEFILE "ARFLAGS := $arflags\n"; print MAKEFILE << 'EOF_MAKFILE'; # Compiler specific definitions # FCCPPDEFS will contain any cpp macro definitions that should appear # as fortran compiler options FCCPPDEFS := ifeq ($(FC:pgf%=pgf), pgf) # Assume portland group fortran compiler FIXED := -Mfixed FREE := -Mfree endif ifeq ($(FC:xlf%=xlf), xlf) # Assume IBM xlf fortran compiler FIXED := -qfixed=72 FREE := -qfree=f90 ifdef COUPLER_COMMIT_ID FCCPPDEFS += -WF,-DCOUPLER_COMMIT_ID=$(COUPLER_COMMIT_ID) endif ifdef COUPLER_REPO_PATH FCCPPDEFS += -WF,-DCOUPLER_REPO_PATH=$(COUPLER_REPO_PATH) endif endif ifeq ($(FC:mpxlf%=mpxlf), mpxlf) # Assume IBM xlf fortran compiler FIXED := -qfixed=72 FREE := -qfree=f90 ifdef COUPLER_COMMIT_ID FCCPPDEFS += -WF,-DCOUPLER_COMMIT_ID=$(COUPLER_COMMIT_ID) endif ifdef COUPLER_REPO_PATH FCCPPDEFS += -WF,-DCOUPLER_REPO_PATH=$(COUPLER_REPO_PATH) endif endif ifeq ($(FC:gfo%=gfo), gfo) # Assume GNU fortran compiler FIXED := -ffixed-form FREE := -ffree-form endif ifeq ($(FC:ftn%=ftn), ftn) ifeq ($(PRGENV:cray%=cray), cray) # crayftn fortran compiler FIXED := -ffixed FREE := -ffree FCCPPDEFS += -DCrayFTN ifdef COUPLER_COMMIT_ID FCCPPDEFS += -DCOUPLER_COMMIT_ID=$(COUPLER_COMMIT_ID) endif ifdef COUPLER_REPO_PATH FCCPPDEFS += -DCOUPLER_REPO_PATH=$(COUPLER_REPO_PATH) endif endif ifeq ($(PRGENV:intel%=intel), intel) # INTEL fortran compiler FIXED := -fixed FREE := -free FCCPPDEFS += -DIntelFTN endif endif ifdef FCCPPDEFS override FFLAGS := $(FFLAGS) $(FCCPPDEFS) endif # Netcdf location and fortran link options ifneq ($(strip $(FC)),ftn) ifdef OPT_ROOT # The root of the netcdf install directory NETCDF_ROOT := $(OPT_ROOT)/netcdf/$(ARCH) # Fortran compiler link options for netcdf NETCDF_INCS := $(shell $(OPT_ROOT)/bin/nf-config --xopt-fc=$(FC) --fflags) NETCDF_LIBS := $(shell $(OPT_ROOT)/bin/nf-config --xopt-fc=$(FC) --flibs) else $(warning NETCDF_INCS and NETCDF_LIBS are not defined.) endif endif ESMF_REQUIRED := 1 ifdef ESMF_REQUIRED # Define ESMF related variables for use below ifndef OPT_ROOT $(error ESMF is required but OPT_ROOT is not defined. Cannot locate ESMF libraries) endif # Identify the location of the ESMF application makefile fragment # TODO: Hard code this location for now ifeq ($(FC:mpxlf%=mpxlf), mpxlf) ESMFMKFILE := $(OPT_ROOT)/esmf/aix64-hadar-esmf-6.3.0rp1-xlf-mpi/lib/esmf.mk endif ifeq ($(FC:ftn%=ftn), ftn) ifeq ($(PRGENV:cray%=cray), cray) ESMFMKFILE := $(OPT_ROOT)/esmf/linux64-hare-esmf-7.0.1-cray-ftn/lib/esmf.mk endif ifeq ($(PRGENV:intel%=intel), intel) ESMFMKFILE := $(OPT_ROOT)/esmf/linux64-hare-esmf-7.0.1-intel-ftn/lib/esmf.mk endif endif ifndef ESMFMKFILE # Set a fall back location which should point to the default for the current ARCH ESMFMKFILE := $(OPT_ROOT)/esmf/$(ARCH)/lib/esmf.mk endif # Include ESMFMKFILE here. This will define # ESMF_F90COMPILER # ESMF_F90LINKER # ESMF_F90COMPILEOPTS # ESMF_F90COMPILEPATHS # ESMF_F90COMPILECPPFLAGS # ESMF_F90COMPILEFREECPP # ESMF_F90COMPILEFREENOCPP # ESMF_F90COMPILEFIXCPP # ESMF_F90COMPILEFIXNOCPP # ESMF_F90LINKOPTS # ESMF_F90LINKPATHS # ESMF_F90LINKRPATHS # ESMF_F90LINKLIBS # ESMF_F90ESMFLINKLIBS # among other ESMF related variables ifeq ($(strip $(wildcard $(ESMFMKFILE))),) # It is an error if ESMFMKFILE does not exist $(error $(ESMFMKFILE) is missing) endif ifeq ($(shell test -r $(ESMFMKFILE) && echo 1),) # It is an error if ESMFMKFILE not readable $(error Unable to read $(ESMFMKFILE)) endif include $(ESMFMKFILE) $(info Using ESMF) # In the xc40 cray environment ESMF_F90COMPILEPATHS contain something like # ... -J/home/scrd102/package/esmf/linux64-hare-esmf-7.0.1-cray-ftn/mod ... # The -J option overrides the default location into which new module files are copied # Modify this by replacing -J with -I so that this make file will find esmf modules # but not try to create new modules in the esmf mod directory ESMF_INCS := $(filter -I%,$(patsubst -J%,-I%,$(ESMF_F90COMPILEPATHS))) # In the cray environment, to link programs that use ESMF routines we need to do one of 2 things # 1) link with $(ESMF_F90LINKER) (CC for cray) and explicitly add the '-lmpichf90' library # to the link line to locate the mpi f90 modules required for "use mpi" in the fortran source # 2) link with $(FC) (ftn on cray) and explicitly add the '-lmpichcxx' library to the # link line to locate MPI::Comm, MPI::Intracomm, etc required by the ESMF c++ source # Choose option 2 so that FC may be used as the linker ESMF_LIBS := $(ESMF_F90LINKPATHS) $(ESMF_F90LINKRPATHS) $(ESMF_F90ESMFLINKLIBS) ifdef PRGENV ESMF_LIBS += -lmpichcxx endif $(info ESMF_INCS = $(ESMF_INCS)) $(info ESMF_LIBS = $(ESMF_LIBS)) else $(warning ESMF is not available) endif # Kernel or machine specific definitions are set separately ifeq ($(MACH_TYPE), linux) CPP := /usr/bin/cpp CPPFLAGS := -P CC := gcc CFLAGS := -g endif ifeq ($(MACH_TYPE), aix) CPP := /usr/bin/cpp CPPFLAGS := -P CC := xlc_r CFLAGS := -g endif EOF_MAKFILE # Determine libraries to link with # Compiled libraries exist in the dir pointed to by the env variable RTEXTBLS # Library names are of the form: # libLOSUB_model_${modver}_${sfx}.a # libLOSUB_comm_${sfx}.a # libLOSUB_diag_${sfx}.a # libLOSUB_plots_${sfx}.a # the sfx may be absent and if it is then the preceeding underscore is as well # sfx is usually one of: # float1 # float1_openmp # float1_openmp_noxlfqinitauto # float2 # openmp_noxlfqinitauto # Linking against the libLOSUB_model_... and libLOSUB_comm_... libraries is # all that is required to compile a model version (e.g. gcm16.dk) my $def_LIBS = ""; my $def_INCS = "-I."; $def_INCS .= " -I$ocndir" if $set_by_usr{ocnver}; #WAIT_AND_SEE # Define default INCS to contain all dirs in which include files were discovered #WAIT_AND_SEE foreach my $abspath ( keys %inc_depends ) { #WAIT_AND_SEE foreach my $inc (@{$inc_depends{$abspath}}) { #WAIT_AND_SEE my ($name, $path, $sfx) = fileparse($inc, ()); #WAIT_AND_SEE $def_INCS .= " -I$path" unless $def_INCS =~ m@ -I$path@; #WAIT_AND_SEE } #WAIT_AND_SEE } # Do not define any default libs if the user has defined LIBS on the command line if ( ($set_by_usr{atmver} or $set_by_usr{modver} or $set_by_usr{ocnver}) and not $usr_LIBS ) { # The user has supplied a model version ...define default libs accordingly # A value for $libsfx was determined above if ( $ENV{RTEXTBLS} ) { # Prepend an underscore to the suffix, if it was defined my $sfx = $libsfx ? "_$libsfx" : ""; my @lib_list = (); push @lib_list, "$ENV{RTEXTBLS}/libLOSUB_model_${atmver}${sfx}.a"; push @lib_list, "$ENV{RTEXTBLS}/libLOSUB_diag${sfx}.a"; push @lib_list, "$ENV{RTEXTBLS}/libLOSUB_comm${sfx}.a"; $def_LIBS = "-L$ENV{RTEXTBLS}"; foreach my $lib_path ( @lib_list ) { unless (-s $lib_path) { warn "** WW ** Missing library $lib_path ...Ignored\n"; next; } my ($libd, $libn) = $lib_path =~ m@^\s*($ENV{RTEXTBLS})/lib(.*)\.a\s*$@; die "Unable to deftermine lib directory for $lib_path.\n" unless $libd; die "Unable to deftermine lib name for $lib_path.\n" unless $libn; $def_LIBS .= " -l$libn"; # Extract the names of all members of this library my @members_in_lib = syscmd( "ar -t $lib_path" ); foreach ( @members_in_lib ) { next unless /\.o\s*$/; $in_lib{$_} = 1; } } # foreach (keys %in_lib) { print "$_ " }; if ( $FC =~ /^(mp)?xlf/i ) { # Add xlf compiler specific libs if ( $with{p5lib} ) { # Not sure about this, should it be -lmassvp4 or -lmassvp5, assume -lmassvp5 $def_LIBS .= " -L/home/crb_ccrn/pollux/acrn/src/plib/p5lib -lessl -lmassvp5 -lmass -lblas"; } else { $def_LIBS .= " -L/usr/lib -lessl -lmassvp5 -lmass -lblas"; } } } else { warn "RTEXTBLS must be defined in your environment in order to define LIBS internally.\n"; warn "The user is responsible for supplying all relevant libraries.\n"; } } if ( $usr_LIBS =~ /^\s*system\s*$/i ) { if ( $FC =~ /^(mp)?xlf/i ) { # Set to use system libraries at the users request when using xlf if ( $with{p5lib} ) { # Not sure about this, should it be -lmassvp4 or -lmassvp5, assume -lmassvp5 $usr_LIBS = " -L/home/crb_ccrn/pollux/acrn/src/plib/p5lib -lessl -lmassvp5 -lmass -lblas"; } else { $usr_LIBS = " -L/usr/lib -lessl -lmassvp5 -lmass -lblas"; } } } # The libraries to be used in the make file are in $LIBS my $LIBS = $def_LIBS; if ( $usr_LIBS ) { # The user has supplied LIBS on the command line my $prepend_usr_LIBS = 1; if ( $prepend_usr_LIBS ) { # Prepend the user supplied libs to the default libs $LIBS = "$usr_LIBS $def_LIBS"; } else { # Use only the user supplied libs $LIBS = "$usr_LIBS"; } } # Set LIBS to a single blank if the only word it contains is "none" $LIBS = " " if $usr_LIBS =~ /^\s*none\s*$/i; # Reset LIBS to a single blank if it contains the word system $LIBS = " " if $LIBS =~ /^\s*system\s*$/i; # The includes to be used in the make file are in $INCS my $INCS = $def_INCS; if ( $usr_INCS ) { # The user has supplied INCS on the command line # Prepend the user supplied incs to the default incs $INCS = "$usr_INCS $def_INCS"; } # Ensure the current dir is present in the include paths substr($INCS,0,0) = "-I. " unless $INCS =~ /(^|\s)-I\s*\.(\s|$)/; if ( $with{ncarg} ) { # Add NCAR graphics libraries # NCARG_ROOT=/fs/dev/crb/had_src/ncar_v442 # NCAR_LIB_PATH=/fs/dev/crb/had_src/ncar_v442/lib # LINKNCAR_float1=-L/fs/dev/crb/had_src/ncar_v442/lib -lncarg -lncarg_gks -lncarg_c -lX11 die "ncarg not yet supported\n"; } # Write these initial values for LIBS and INCS to the make file print MAKEFILE "LIBS := $LIBS\n"; print MAKEFILE "INCS := $INCS\n\n"; if ( $build_coupler == 1) { print MAKEFILE << 'EOF_MAKFILE'; ifdef ESMF_INCS override INCS := $(INCS) $(ESMF_INCS) endif ifdef ESMF_LIBS override LIBS := $(LIBS) $(ESMF_LIBS) endif EOF_MAKFILE } print MAKEFILE << 'EOF_MAKFILE'; ifdef NETCDF_INCS override INCS := $(INCS) $(NETCDF_INCS) endif ifdef NETCDF_LIBS override LIBS := $(LIBS) $(NETCDF_LIBS) endif ifndef FIXED $(error The macro FIXED is undefined. You may need to add a definition to your include file) endif ifndef FREE $(error The macro FREE is undefined. You may need to add a definition to your include file) endif .SILENT: clean EOF_MAKFILE print MAKEFILE ".DEFAULT:\n"; print MAKEFILE "\t\@echo Target \$@ does not exist.\n"; print MAKEFILE "\n"; # Include a user supplied file that can redefine any of the macros defined above # It can also be used to add new macro defs or additional targets etc if ( $make_include_file ) { print MAKEFILE "\ninclude $make_include_file\n\n"; } if ( $all_target ) { print MAKEFILE "all: $all_target\n"; } print MAKEFILE "\n"; # Write all targets to the makefile write_targets( \*MAKEFILE ); print MAKEFILE "\n"; print MAKEFILE ".PHONY: debug\n"; print MAKEFILE "debug:\n"; print MAKEFILE "\t",'@echo FC = $(FC)',"\n"; print MAKEFILE "\t",'@echo FFLAGS = $(FFLAGS)',"\n"; print MAKEFILE "\t",'@echo CPP = $(CPP)',"\n"; print MAKEFILE "\t",'@echo CPPFLAGS = $(CPPFLAGS)',"\n"; print MAKEFILE "\t",'@echo LIBS = $(LIBS)',"\n"; print MAKEFILE "\t",'@echo INCS = $(INCS)',"\n"; for (my $mcount=1; $mcount <= $main_count; $mcount++) { print MAKEFILE "\t",'@echo IDEPS',"$mcount",' = $(IDEPS',"$mcount)\n"; print MAKEFILE "\t",'@echo MDEPS',"$mcount",' = $(MDEPS',"$mcount)\n"; print MAKEFILE "\t",'@echo ODEPS',"$mcount",' = $(ODEPS',"$mcount)\n"; } print MAKEFILE "\t",'@echo DOMAIN = $(DOMAIN)',"\n"; print MAKEFILE "\n"; print MAKEFILE "# (re)define certain default rules\n"; print MAKEFILE "%.o: %.f\n"; print MAKEFILE "\t",'$(FC) -c $(FIXED) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "%.o: %.F\n"; print MAKEFILE "ifdef cppdefs\n"; print MAKEFILE "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print MAKEFILE "\t",'tmpfile=$*_$(STAMP).F; rm -f $$tmpfile; \\',"\n"; print MAKEFILE "\techo '",'#include "$(cppdefs)"',"'",' | cat - $*.F > $$tmpfile && \\',"\n"; print MAKEFILE "\t",'$(FC) -c $(FIXED) $(FFLAGS) $$tmpfile $(INCS) -o $*.o && rm -f $$tmpfile',"\n"; print MAKEFILE "else\n"; print MAKEFILE "\t",'$(FC) -c $(FIXED) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "endif\n"; print MAKEFILE "%.o: %.F90\n"; print MAKEFILE "ifdef cppdefs\n"; print MAKEFILE "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print MAKEFILE "\t",'tmpfile=$*_$(STAMP).F; rm -f $$tmpfile; \\',"\n"; print MAKEFILE "\techo '",'#include "$(cppdefs)"',"'",' | cat - $*.F > $$tmpfile && \\',"\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $$tmpfile $(INCS) -o $*.o && rm -f $$tmpfile',"\n"; print MAKEFILE "else\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "endif\n"; print MAKEFILE "%.o: %.f90\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "%.o: %.F95\n"; print MAKEFILE "ifdef cppdefs\n"; print MAKEFILE "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print MAKEFILE "\t",'tmpfile=$*_$(STAMP).F; rm -f $$tmpfile; \\',"\n"; print MAKEFILE "\techo '",'#include "$(cppdefs)"',"'",' | cat - $*.F > $$tmpfile && \\',"\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $$tmpfile $(INCS) -o $*.o && rm -f $$tmpfile',"\n"; print MAKEFILE "else\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "endif\n"; print MAKEFILE "%.o: %.f95\n"; print MAKEFILE "\t",'$(FC) -c $(FREE) $(FFLAGS) $< $(INCS) -o $*.o',"\n"; print MAKEFILE "\n"; print MAKEFILE "# Cancel the implicit RCS extraction rule to avoid getting\n"; print MAKEFILE "# unwanted source files copied to the build directory\n"; print MAKEFILE "% :: RCS/%,v\n"; print MAKEFILE "\n"; close(MAKEFILE); print "Created $make_file\n"; } sub byfile { # Sort lexically by file base names (everything after the last "/") use strict; my ($na, $nb, $p, $s); ($na, $p, $s) = fileparse($a,()); ($nb, $p, $s) = fileparse($b,()); $na cmp $nb; } sub modbydep { # Sort module in order of dependencies (least dependent first) # given 2 different module names use strict; my ($adep, $bdep); $adep = 0; $bdep = 0; if ( $mod_path{$a} and $mod_path{$b} ) { # Both a and b have a known file name associated if ( $mod_depends{$mod_path{$a}} ) { foreach my $ma ( @{$mod_depends{$mod_path{$a}}} ) { # Module a depends on module b if ($ma eq $mod_path{$b}) { $adep = 1; last; } } } if ( $mod_depends{$mod_path{$b}} ) { foreach my $mb ( @{$mod_depends{$mod_path{$b}}} ) { # Module b depends on module a if ($mb eq $mod_path{$a}) { $bdep = 1; last; } } } } $adep <=> $bdep; } sub modobjbydep { # Sort modules in order of dependencies (least dependent first) # given 2 different object file names use strict; my ($adep, $bdep); $adep = 0; $bdep = 0; if ( $obj_path{$a} and $obj_path{$b} ) { # Both a and b have a known file name associated if ( $mod_depends{$obj_path{$a}} ) { foreach my $ma ( @{$mod_depends{$obj_path{$a}}} ) { # Module a depends on module b if ($ma eq $obj_path{$b}) { $adep = 1; last; } } } if ( $mod_depends{$obj_path{$b}} ) { foreach my $mb ( @{$mod_depends{$obj_path{$b}}} ) { # Module b depends on module a if ($mb eq $obj_path{$a}) { $bdep = 1; last; } } } } $adep <=> $bdep; } sub filter_deps { # Filter the dependency list to remove dependencies that are already # compiled and provided in a library that appears on the compile command line # Even though they are in a library they may still need to be compiled if they # also appear in a dir that was supplied by the user use strict; my @deps; foreach my $dep (@_) { if ( $obj_path{$dep} ) { push @deps,$dep unless $in_lib{$dep}; # Need to know the base_filename for this dependency # my ($name) = fileparse($obj_path{$dep},()); # push @deps,$dep unless ($in_lib{$dep} and not $compile_file{$name}); } else { # Otherwise we always keep this dependency push @deps,$dep; } } return @deps; } sub write_targets { # Write rules for all targets to the makefile use strict; my $TARGETS = shift; my %wrote_dep; my %hasmod; my %isinc; my $main_exe = ""; my $xtra_clean = ""; my $IDEPS_name = "IDEPS" . "$main_count"; my $MDEPS_name = "MDEPS" . "$main_count"; my $ODEPS_name = "ODEPS" . "$main_count"; #??? my @lib_mod_mem = (); #??? my @lib_obj_mem = (); # Put "main" targets at the top of the list so they are written first to the make file # Also identify files that either contain modules or are included via "#include" my @local_list; my @tmp_list; foreach my $fpath (@DEP_list) { my ($name, $path, $suffix) = fileparse($fpath, @suffix_list); if ($is_main{"$name$suffix"}) { push @local_list, $fpath; } else { push @tmp_list, $fpath; } # Look for files that contain modules and add them to the %hasmod hash if ($mod_depends{$fpath}) { if ($verbose > 10) { print "modules used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$mod_depends{$fpath}})),"\n"; } foreach my $mpath (@{$mod_depends{$fpath}}) { my ($nam, $pth, $sfx) = fileparse( $mpath, @suffix_list); my $dep = "$nam.o"; # If there was no valid suffix then use the full name $dep = $nam unless $sfx; # Flag this object file as one containing a module $hasmod{$dep} = 1; } } # Look for files that are included via "#include" or "%CALL" directives # and add them to the %isinc hash if ($inc_depends{$fpath}) { foreach my $ipath (@{$inc_depends{$fpath}}) { my ($nam, $pth, $sfx) = fileparse( $ipath, @suffix_list); my $dep = $nam.$sfx; if ( "$nam$sfx" eq 'xit2.cdk' ) { # Special case required for xit2.cdk since it does not follow the rules $dep = "$nam.o"; } elsif ("$sfx" eq '.cdk') { $dep = "$nam.h"; } # Flag this object file as one that is included via "#include" or "%CALL" # Exclude xit2.o from this list $isinc{$dep} = 1 unless "$nam$sfx" eq 'xit2.cdk'; } } } push @local_list, sort byfile @tmp_list; undef @tmp_list; foreach my $fpath ( @local_list ) { # Loop over each required file and add make targets for each file # Ignore any files found in the "missing" subdir of the build dir # next if $fpath =~ /^missing\//; # Ignore files without one of the suffixes in suffix_list my ($name, $path, $suffix) = fileparse($fpath, @suffix_list); unless ( $suffix ) { # This is likely a file that is included via an "#include" directive # and does not have a normal suffix (e.g. CPP_I, CPP_I_ocean, etc) # Add a target for this file that will simply check date and mod time if ( $name eq $fpath ) { print $TARGETS "$name :\n"; } else { print $TARGETS "$name : $fpath\n"; print $TARGETS "$fpath :\n"; } next; } # if ( $name eq "cosp" ) { # print "$fpath\n"; # } # If this file is in a library that appears on the compile command line # and it is not found in a dir supplied by the user then it should # not be compiled next if ($in_lib{"$name.o"} and not $compile_file{"$name$suffix"}); # Create a list of file dependencies my @deps = (); # Insert modules first in dependency list if ($mod_depends{$fpath}) { foreach my $module (sort modbydep @{$mod_depends{$fpath}}) { my ($mname, $mpath, $msuffix) = fileparse( $module, @suffix_list); # Do not add the file itself as a dependency next if "$name$suffix" eq "$mname$msuffix"; my $dep = "$mname.o"; # If there was no valid suffix then use the full name $dep = $mname unless $msuffix; push @deps, $dep unless grep /^$dep$/, @deps; # Identify the file associated with this object $obj_path{$dep} = $module; $obj_file{$dep} = "$mname$msuffix"; if ($verbose > 10) { print "write_targets: Module $dep used by $name$suffix\n"; } } } # Then includes if ($inc_depends{$fpath}) { foreach my $include (@{$inc_depends{$fpath}}) { my ($iname, $ipath, $isuffix) = fileparse( $include, @suffix_list); # Do not add the file itself as a dependency next if "$name$suffix" eq "$iname$isuffix"; my $dep = $iname.$isuffix; if ( "$iname$isuffix" eq 'xit2.cdk' ) { # Special case required for xit2.cdk since it does not follow the rules $dep = "$iname.o"; } elsif ("$isuffix" eq '.cdk') { $dep = "$iname.h"; } push @deps, $dep unless grep /^$dep$/, @deps; # Identify the file associated with this object $obj_path{$dep} = $include; $obj_file{$dep} = "$iname$isuffix"; if ($verbose > 10) { print "write_targets: File $dep included with $name$suffix\n"; } } } # Then all other files if ($all_depends{$fpath}) { foreach my $afile (@{$all_depends{$fpath}}) { my ($aname, $apath, $asuffix) = fileparse( $afile, @suffix_list); # Do not add the file itself as a dependency next if "$name$suffix" eq "$aname$asuffix"; my $dep = $aname.".o"; # If this is not a target then use the base name as the dependency name $dep = "$aname$asuffix" unless $is_target{"$aname$asuffix"}; if ( "$aname$asuffix" eq 'xit2.cdk' ) { # Special case required for xit2.cdk since it does not follow the rules $dep = "$aname.o"; } elsif ("$asuffix" eq '.cdk') { # ".cdk" include files are preprocessed by up2cpp and renamed with a ".h" suffix $dep = "$aname.h"; } push @deps, $dep unless grep /^$dep$/, @deps; # Identify the file associated with this object $obj_path{$dep} = $afile; $obj_file{$dep} = "$aname$asuffix"; if ($verbose > 10) { print "write_targets: File $dep required by $name$suffix\n"; } } } # Filter the dependency list for this file to remove dependencies that are already # compiled and provided in a library that appears on the compile command line # Even though they are in a library they may still need to be compiled if they # also appear in a dir that was supplied by the user # @deps = filter_deps( @deps ); # Write the target rule my $prog = "$name$suffix"; unless ( $wrote_dep{$prog} ) { $wrote_dep{$prog} = 1; my $fmtmacro = '$(FIXED)'; $fmtmacro = '$(FREE)' if $freefmt{"$name$suffix"}; # Separate object files that contain modules from those that do not # and distinguish between "included" files and other dependencies my (@DEPS_m, @DEPS_o, @DEPS_h); foreach my $obj (@deps) { if ( $hasmod{$obj} ) { push @DEPS_m, $obj; } else { if ( $isinc{$obj} ) { push @DEPS_h, $obj; } else { push @DEPS_o, $obj; } } } # Sort module objects according to dependency @DEPS_m = sort modobjbydep @DEPS_m; # my @tmparr = sort modobjbydep @DEPS_m; # @DEPS_m = @tmparr; # undef @tmparr; # Define a variable containing all dependencies my $DEPS = "@DEPS_h @DEPS_m @DEPS_o"; #??? # Add all module and ".o" dependencies we encounter to pair of lists #??? # These lists will be used below if a library target is created #??? foreach my $member ( @DEPS_m ) { #??? if ( $obj_path{$member} ) { #??? # Do not add any ".dk" or ".cdk" files to the library #??? my ($name, $path, $sfx) = fileparse($obj_path{$member}, @suffix_list); #??? next if $sfx eq ".dk"; #??? next if $sfx eq ".cdk"; #??? } #??? push @lib_mod_mem, $member unless grep /^$member$/, @lib_mod_mem; #??? } #??? foreach my $member ( @DEPS_o ) { #??? if ( $obj_path{$member} ) { #??? # Do not add any ".dk" or ".cdk" files to the library #??? my ($name, $path, $sfx) = fileparse($obj_path{$member}, @suffix_list); #??? next if $sfx eq ".dk"; #??? next if $sfx eq ".cdk"; #??? } #??? push @lib_obj_mem, $member unless grep /^$member$/, @lib_obj_mem; #??? } # Add options to the the up2cpp command used in certain targets below my $up2cpp_opts = "modver=$atmver --overwrite --quiet"; $up2cpp_opts .= " --mpi" if $with{mpi}; $up2cpp_opts .= " --coupled" if $with{coupled}; my $sizes_dep = ""; if ( $has_cppdefs{"$name$suffix"} and $cppdefs_file ) { # The user has supplied a cpp directives file # Incorporate this file name into certain targets below $up2cpp_opts .= $up2cpp_opts ? " cppdefs=$cppdefs_file" : "cppdefs=$cppdefs_file"; $DEPS .= $DEPS ? " $cppdefs_file" : $cppdefs_file unless $DEPS =~ /(^|\s)$cppdefs_file(\s|$)/; } if ( $has_ddelim{"$name$suffix"} and $sizes_file ) { # The user has supplied a file containing replacement values for "$" delimited # text strings which may appear in some source code files # Incorporate this file name into certain targets below $up2cpp_opts .= $up2cpp_opts ? " sizes=$sizes_file" : "sizes=$sizes_file"; $DEPS .= $DEPS ? " $sizes_file" : $sizes_file unless $DEPS =~ /(^|\s)$sizes_file(\s|$)/; $sizes_dep = "$sizes_file"; } if ($is_main{"$name$suffix"}) { # Add definitions for IDEPS, MDEPS and ODEPS to the make file # If there are multiple main targets then each IDEPS, MDEPS and ODEPS macro must # have unique name within the make file. Ensure this by appending a counter value # to each macro name that gets incrimented each time these macro defs are written $main_count++; $IDEPS_name = "IDEPS" . "$main_count"; $MDEPS_name = "MDEPS" . "$main_count"; $ODEPS_name = "ODEPS" . "$main_count"; print $TARGETS "\n"; print $TARGETS "$IDEPS_name = @DEPS_h\n"; print $TARGETS "$MDEPS_name = @DEPS_m\n"; print $TARGETS "$ODEPS_name = @DEPS_o\n"; print $TARGETS "\n"; } # Write targets to create the object files if ( "$suffix" eq '.dk' or "$name$suffix" eq 'xit2.cdk' ) { # Convert '.dk' files to fortran with embedded cpp directives # These will be complete program|subroutine|function|module definitions # hence the '.F' suffix # xit2.cdk must be included here since it does not follow rules for '.cdk' files $xtra_clean .= " $name.F"; # Add a target to replace update directives with cpp directives and replace # any "$" delimited variables with user supplied values print $TARGETS "$name.F : $fpath\n"; print $TARGETS "\tup2cpp --out_file=$name.F $up2cpp_opts $fpath\n"; # Add a second target to compile if ($is_main{"$name$suffix"}) { print $TARGETS "$name.o : $name.F \$($IDEPS_name) \$($MDEPS_name) \$($ODEPS_name)\n"; # print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $name.F\n"; } else { print $TARGETS "$name.o : $name.F $DEPS\n"; # print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $name.F\n"; } print $TARGETS "ifdef cppdefs\n"; print $TARGETS "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print $TARGETS "\t","tmpfile=${name}_",'$(STAMP).F; rm -f $$tmpfile; \\',"\n"; print $TARGETS "\techo '",'#include "$(cppdefs)"',"'",' | cat - ',"$name.F",' > $$tmpfile && \\',"\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $$tmpfile $(INCS) -o ',"$name.o\n"; print $TARGETS "else\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $< $(INCS) -o ',"$name.o\n"; print $TARGETS "endif\n"; unless ($is_main{"$name$suffix"}) { $proj_member{"$name.o"} = 1; } } elsif ( "$suffix" eq '.cdk' ) { # Convert '.cdk' files to fortran with embedded cpp directives # These will be partial program fragments, hence the '.h' suffix $xtra_clean .= " $name.h"; print $TARGETS "$name.h : $fpath $sizes_dep\n"; print $TARGETS "\tup2cpp --out_file=$name.h $up2cpp_opts $fpath\n"; } else { # All other targets are simply compiled if ($is_main{"$name$suffix"}) { print $TARGETS "$name.o : $fpath \$($IDEPS_name) \$($MDEPS_name) \$($ODEPS_name)\n"; # print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $fpath\n"; if ( $suffix eq ".F" or $suffix eq ".F90" ) { print $TARGETS "ifdef cppdefs\n"; print $TARGETS "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print $TARGETS "\t","tmpfile=${name}_",'$(STAMP)',"$suffix",'; rm -f $$tmpfile; \\',"\n"; print $TARGETS "\techo '",'#include "$(cppdefs)"',"'",' | cat - ',"$fpath",' > $$tmpfile && \\',"\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $$tmpfile $(INCS) -o ',"$name.o\n"; print $TARGETS "else\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $< $(INCS) -o ',"$name.o\n"; print $TARGETS "endif\n"; } else { print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $< $(INCS) -o ',"$name.o\n"; } } else { if ( $set_by_usr{ocnver} and $path =~ m@^$ocndir@ ) { # This file lives in the ocean source dir if ( "$suffix" eq '.F' ) { # These files require preprocessing with CPP print $TARGETS "$name.o : $fpath $DEPS\n"; if ( $ocn_use_cpp ) { # Preprocess these files using the system cpp processor # This may be required if the ocean source if from CanESM4.1 or earlier and # it has not been filtered to remove c-style comments and cpp continuation # lines from all cpp directives found in this source file my $tmpfile = "$name.f"; $xtra_clean .= " $tmpfile"; print $TARGETS "\tcd $ocndir && \$(CPP) \$(CPPFLAGS) $fpath $tmpfile\n"; print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $ocndir/$tmpfile\n"; } else { # Otherwise use the fortran preprocessor print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $fpath\n"; } } elsif ( "$suffix" eq '.h' ) { # Create null targets for these include files print $TARGETS "$name.h:\n"; # print $TARGETS "$name.h : $fpath $DEPS\n"; # print $TARGETS "$fpath :\n"; $xtra_clean .= " $name.h"; } else { # These are all the CPP_I* files print $TARGETS "${name}:\n"; # print $TARGETS "$name : $fpath $DEPS\n"; # print $TARGETS "\tcp $fpath .\n"; $xtra_clean .= " $name"; } } else { print $TARGETS "$name.o : $fpath $DEPS\n"; if ( "$suffix" eq '.F' or "$suffix" eq '.F90' ) { print $TARGETS "ifdef cppdefs\n"; print $TARGETS "\t",'@# Prepend each file with a directive to include cppdefs',"\n"; print $TARGETS "\t","tmpfile=${name}_",'$(STAMP)',"$suffix",'; rm -f $$tmpfile; \\',"\n"; print $TARGETS "\techo '",'#include "$(cppdefs)"',"'",' | cat - ',"$fpath",' > $$tmpfile && \\',"\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $$tmpfile $(INCS) -o ',"$name.o\n"; print $TARGETS "else\n"; print $TARGETS "\t",'$(FC) -c ',"$fmtmacro",' $(FFLAGS) $< $(INCS) -o ',"$name.o\n"; print $TARGETS "endif\n"; } else { print $TARGETS "\t\$(FC) -c $fmtmacro \$(FFLAGS) \$(INCS) $fpath\n"; } $proj_member{"$name.o"} = 1; } } } # If this is a file containing a main program then create a target # that will link the object file to other objects and libs if ($is_main{"$name$suffix"}) { # This is a "main" program target # Use the user supplied name found in main_target_name or default to the file name my $target_name = $main_target_name{$name} ? $main_target_name{$name} : $name; # Save this main target name to use in the verylean target below $main_exe .= " $target_name"; print $TARGETS "$target_name : $name.o\n"; my $proj_lib_opt = ""; $proj_lib_opt = "-L. -l$proj_lib" if $proj_lib; print $TARGETS "\t\$(FC) \$(FFLAGS) \$(INCS) $name.o -o $target_name $proj_lib_opt \$(LIBS)\n"; print $TARGETS "\n"; } } } if ( scalar(keys %proj_member) ) { # Write a target to create a library containing all project object files # Divide this list into files that contain modules and files that don't my @module_members; my @other_members; foreach ( keys %proj_member ) { if ( $obj_file{$_} ) { if ( $contains_mod{$obj_file{$_}} ) { push @module_members, $_; } else { push @other_members, $_; } if ( $verbose > 10 ) { print "$_ uses_mod" if $uses_mod{$obj_file{$_}}; if ( $obj_path{$_} ) { print " $obj_path{$_}"; if ( $mod_depends{$obj_path{$_}} ) { print "\n\tdepends on: "; foreach my $dep ( @{$mod_depends{$obj_path{$_}}} ) { my $f = basename $dep; print " $f"; } print "\n"; } } else { print " no obj_path for $_\n"; } } } else { warn "\n** WW ** obj_file is not defined for library member $_\n"; push @other_members, $_; } } if ( scalar( @module_members ) ) { # Sort module objects according to dependency (least dependent first) my @tmp_members = sort modobjbydep @module_members; @module_members = @tmp_members; if ( $verbose > 10 ) { foreach ( @module_members ) { if ( $obj_path{$_} ) { print " $obj_path{$_}"; if ( $mod_depends{$obj_path{$_}} ) { print "\n\tdepends on: "; foreach my $dep ( @{$mod_depends{$obj_path{$_}}} ) { my $f = basename $dep; print " $f"; } print "\n"; } } else { print " no obj_path for $_\n"; } } } } #TODO# Ensure that any modules that are to become members of this lib get added #TODO# to the archive before other files and that all modules are inserted in #TODO# order of dependency, most dependent first print $TARGETS "\n# Create the local project library\n"; print $TARGETS "PROJ_MEMBERS = @module_members @other_members\n"; print $TARGETS "PROJ_MEMBERS := \$(strip \$(PROJ_MEMBERS))\n"; print $TARGETS "\$(PROJ_LIB): \$(PROJ_MEMBERS)\n"; print $TARGETS "ifndef PROJ_MEMBERS\n"; print $TARGETS "\t\$(error Cannot create the project library. Empty members list)\n"; print $TARGETS "endif\n"; print $TARGETS "\t\$(AR) -rus \$(PROJ_LIB) \$(PROJ_MEMBERS)\n"; # Add this library file to the veryclean list if not already there # push @veryclean_flist, $libfile unless grep /^$libfile$/,@veryclean_flist; } # Write "clean" target print $TARGETS "\n"; print $TARGETS "clean:\n"; print $TARGETS "\t\@rm -f *.o *.lst *.mod $xtra_clean\n"; # Write "veryclean" target # main_exe will contain a list of executables that were created, if any # Add a few misc files created by this program to this list my $veryclean_list = "$main_exe pax_global_header"; if ( $veryclean_list or scalar(@up2patch_flist) or scalar(@veryclean_flist) ) { print $TARGETS "\nveryclean: clean\n"; # Remove executables and other misc files created by cccmf print $TARGETS "\t\@rm -f $veryclean_list\n" if $veryclean_list; # The veryclean target should also remove files created by up2patch, if any print $TARGETS "\t\@rm -f ",join(" ",@up2patch_flist),"\n" if scalar(@up2patch_flist); # The veryclean target should also remove certain files print $TARGETS "\t\@rm -f ",join(" ",@veryclean_flist),"\n" if scalar(@veryclean_flist); } return 1; } sub prep_source { # Preprocess the input source code to: # - remove comments # - concatenate continuation lines # - analyse then remove interface blocks # - optionaly, under control of the user, remove code inside certain # preprocessor conditional blocks (%IF .. %ENDIF or #if .. #endif) # in cases where that code would be removed at compile time use strict; # Source code to preprocess my $fsrc = shift; # Full pathname for this source my $abspath = shift; # Determine if there are cpp preprocessor lines in this file # by looking for any lines that begin with "#" or "%" # Update directives (lines that begin with "%") will be converted # to cpp directives before compilation by the makefile # Note that a false positive may be found if the file contains a single # "%deck" line, but this is ok since all it means is that the preprocessor # will be run on that file at compile time and this will work whether the # file actually contains cpp directives or not # This check needs to be done before running pipe_from_cpp since it is the # original disk file that will be used by the make file my ($name, $path, $sfx) = fileparse("$abspath", ()); $has_cppdefs{"$name$sfx"} = 1 if $fsrc =~ /(^|\n)[#%]/; if ( $cppdefs_file and $fsrc =~ /^#/m) { # Remove all #if ... #endif blocks from the disk file found in $abspath # removing (or not) conditional code as determined by the preprocessor # directives found in the file $cppdefs_file # Any "#include" lines that appear in this file will not be affected # since they are required for finding include dependencies later # Note this will read the source from the file and overwrite anything # that was previously in $fsrc so this should be the first thing done # after the above check for cpp directives $fsrc = pipe_from_cpp( $abspath, $cppdefs_file ); } if (%undefs) { # remove lines of code within specified # %IF ... %ENDIF update or #if #endif cpp directives my $subOPTS = {VERBOSE=>$verbose, UNDEFS=>\%undefs, FNAME=>$abspath}; #TODO $fsrc = rm_undef_blocks($fsrc, $subOPTS); } # Analyse then remove any fortran interface blocks to avoid a # false positive id of subroutines or functions defined therein $fsrc = rm_interface_block($fsrc, {VERBOSE=>0, FNAME=>$abspath}); # Concatenate fortran continuation lines into single physical lines $fsrc = cat_fortran_lines($fsrc, {VERBOSE=>0, FNAME=>$abspath}); # remove all comments from the fortran source code $fsrc = rm_fortran_comments($fsrc, {VERBOSE=>0, FNAME=>$abspath}); # Determine if there are any "$" delimited text segments (lines containing "$word$") # These are present in some atm source files and are intended to be replaced with # another string (typically a dimension size) prior to compilation # This should be done on the preprocessed source code so that continuation lines # and comments are removed, which will mitigate false positive matches $has_ddelim{"$name$sfx"} = 1 if $fsrc =~ /\$\w+\$/m; return $fsrc; } sub scan_path_list { use strict; # Scan each directory in the input dir list for source files and for each file found # read and preprocess the source file and hash the resulting source # against the absolute path name foreach my $dir (@_) { next unless (-d $dir); unless (opendir DIR, $dir) { warn "** WW ** Cannot open directory $dir ...Ignored\n"; next; } foreach my $fn (readdir DIR) { my $abspath = "$dir/$fn"; # Ignore anything that is not a regular file next unless (-f "$abspath"); # Read and preprocess this file and set certain global hash values scan_file( $abspath ); } closedir DIR; } return 1; } sub scan_file { # read and preprocess the source file and hash the resulting source # against the absolute path name use strict; my $abspath = shift; die "scan_file: abspath is missing. Stopped" unless $abspath; my ($name, $path, $suffix) = fileparse("$abspath", @suffix_list); # ignore any files that do not have an appropriate suffix return unless $suffix; # Ignore files that have been explicitly excluded if ( $exclude_file{"$name$suffix"} ) { if ( $verbose > 10 ) { print "Excluding $name$suffix\n"; } return; } # Once a file has been read, all subsequent encounters with a file # of the same name are ingnored. This allows the user to replace any # file in the "standard" directory tree with their own version by simply # putting a copy of that file in the invoking dir, or in one of the user # directories supplied on the command line return if $scanned_this_file{"$name$suffix"}; $scanned_this_file{"$name$suffix"} = 1; # read the source code into memory and preprocess unless (-f $abspath) { die "${Runame} $abspath is not a regular file\n"; } if ( $CCRNSRC and $abspath =~ /^$CCRNSRC/ ) { # Always assume fixed format source for standard CCCma source code $FIXED_format = 1; # do not allow cat_fortran_lines or rm_fortran_comments to change this assumtion $allow_set_format = 0; } else { # Use the default format (fixed or free) for all source but.. $FIXED_format = 1; # allow cat_fortran_lines or rm_fortran_comments to change this $allow_set_format = 1; } # print "default_FIXED_format = $default_FIXED_format FIXED_format = $FIXED_format allow_set_format = $allow_set_format\n"; my $fsrc = ''; if (open(FSRC, "<$abspath")) { # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, continuation lines, # interface blocks and possibly some cpp conditional blocks $fsrc = prep_source( $fsrc, $abspath); } else { warn "** WW ** Cannot open file $abspath ...Ignored\n"; return; } # hash the preprocessed source against the abs pathname $source{$abspath} = $fsrc; # Identify the full pathname of this file $full_path{"$name$suffix"} = $abspath; # Keep track of which files contain free format fortran source $freefmt{"$name$suffix"} = isfreefmt($abspath, $fsrc); # Also identify which files contain modules and which files use modules $contains_mod{"$name$suffix"} = $source{$abspath} =~ /^\s*module\s/mi; $uses_mod{"$name$suffix"} = $source{$abspath} =~ /^\s*use\s/mi; if ( $fsrc =~ /(^|\n)\s*program\s+\w/i ) { # This file contains a main program $is_main{"$name$suffix"} = 1; } else { $is_main{"$name$suffix"} = 0; } # grab the last line of this src that is not a line beginning with "#" # $fsrc will have all comments removed but cpp or update directives may remain # Remove all cpp/update directives from a copy of fsrc before extracting the last line my $tmpsrc = ""; foreach (split /\n/, $fsrc) { next if /^[#%]/; $tmpsrc .= "$_\n"; } my ($last_line) = $tmpsrc =~ /\n([^\n]*)$/s; undef $tmpsrc; if ( $last_line ) { # look for a valid fortran end statment # Note: we assume that all comments have already been removed my $kwrd = '(block|function|module|program|subroutine)'; if ($last_line =~ /^(\s*end\s*$|\s*end\s*$kwrd)/i) { # If this is a valid fortran end statement then we likely want # to create a target in the makefile to compile this source $is_target{"$name$suffix"} = 1; } else { # otherwise this is a code snippet (include file) and we likely # don't want to create a target for it $is_target{"$name$suffix"} = 0; } if (exists $usr_target{"$name$suffix"}) { # Allow the user to change this behaviour $is_target{"$name$suffix"} = $usr_target{"$name$suffix"}; } } else { if ( $verbose > 10 ) { print "No last line found in file $abspath\n"; } } # Scan the preprocessed source code for functions, subroutines, modules # and populate each global hash; %func_path, %sub_path, %mod_path scan_source( $abspath ); return 1; } sub scan_source { use strict; my $abspath = shift; # Scan the input source for fortran function, subroutine or # module definitions as well as common blocks and hash the names of # each of these entities against absoute path names my @names = (); if ($verbose > 10) {print "$abspath\n"}; # get a list of fortran functions defined in the source file @names = find_fortran_function( {FILE => $abspath, SRC => $source{$abspath}, VERBOSE => $verbose}); foreach my $name (@names) { if (exists $func_path{$name}) { if ( $verbose > -1 ) { warn "The function $name was previously defined in $func_path{$name}\n"; warn " $name is also defined in $abspath\n"; } $dup_func_path{$name} = $abspath; } else { $func_path{$name} = $abspath; if ($verbose > 2) { printf " function %-15s %s %s\n", $name,"found in",$func_path{$name}; } } } # get a list of fortran subroutines defined in the source file @names = find_fortran_subroutine( {FILE => $abspath, SRC => $source{$abspath}, VERBOSE => $verbose}); foreach my $name (@names) { if (exists $sub_path{$name}) { if ( $verbose > -1 ) { warn "The subroutine $name was previously defined in $sub_path{$name}\n"; warn " $name is also defined in $abspath\n"; } $dup_sub_path{$name} = $abspath; } else { $sub_path{$name} = $abspath; if ($verbose > 2) { printf "subroutine %-15s %s %s\n", $name,"found in",$sub_path{$name}; } } } # get a list of fortran modules defined in the source file @names = find_fortran_module( {FILE => $abspath, SRC => $source{$abspath}, VERBOSE => $verbose}); foreach my $name (@names) { if (exists $mod_path{$name}) { if ( $verbose > -1 ) { warn "The module $name was previously defined in $mod_path{$name}\n"; warn " $name is also defined in $abspath\n"; } $dup_mod_path{$name} = $abspath; } else { $mod_path{$name} = $abspath; if ($verbose > 2) { printf " module %-15s %s %s\n", $name,"found in",$mod_path{$name}; } } } my $look_for_common_blocks = 0; if ( $look_for_common_blocks ) { # find any fortran common blocks in the source file @names = find_fortran_common( {FILE => $abspath, SRC => $source{$abspath}, VERBOSE => $verbose}); foreach my $name (@names) { push @{$com_path{$name}}, $abspath unless grep /^$abspath$/, @{$com_path{$name}}; } } if ($verbose > 100) {print "$source{$abspath}\n"}; return 1; } sub find_depends {my ($OPTS) = @_; # Find all files that are required by procedures in the input file # find_depends will populate the following hashes # %child_of # %not_found # %scanned_by_find_dep # keys in the following hashes are full pathnames and the associated # values are list references pointing to lists of file names on which # the key file depends # %mod_depends a ref to a list of file names containing modules # %inc_depends a ref to a list of file names containing includes # %all_depends a ref to a list of all file names use strict; use Text::Tabs; use Cwd qw(abs_path); my ($name, $path, $suffix); my $aname; my $dep_count = 0; # Find dependencies given the name of a file that contains # fortran source code my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $level = 0; if (defined $OPTS->{LEVEL}) {$level = $OPTS->{LEVEL} + 1}; my $fsrc = ''; if (defined $OPTS->{SRC}) {$fsrc = $OPTS->{SRC}}; # FILE is mandatory and fname must exist my $fname = ''; if (defined $OPTS->{FILE}) {$fname = $OPTS->{FILE}}; unless ($fname) { die "${Runame}::find_depends FILE is missing or emtpy. Stopped"; } unless (-f $fname) { die "${Runame}::find_depends $fname is not a regular file. Stopped"; } ($name, $path, $suffix) = fileparse($fname,@suffix_list); if ($verbose > 10) { print "fname=$fname :: path=$path name=$name suffix=$suffix\n"; } my %path_of; my %src_of; # determine the basename of the incomming file name my $bname = "$name$suffix"; if ($verbose > 2) { print "===================== level: $level === file: $bname ===\n"; } unless ($fsrc) { # If the source is not passed in via the SRC option # check to see if it has been read in main if (exists $source{$fname}) {$fsrc = $source{$fname}}; unless ($fsrc) { # otherwise attempt to read it from a file named $fname if ($verbose > 0) {print "find_depends: reading file $fname\n"}; open(FSRC, "<$fname") or die "${Runame}::find_depends Cannot open file $fname. Stopped"; $fsrc = ''; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, # continuation lines and interface blocks $fsrc = prep_source( $fsrc, $fname ); } } if ( 0 and $cppdefs_file and $fsrc =~ /^#/m) { # Remove all #if ... #endif blocks from the disk file found in $abspath # removing (or not) conditional code as determined by the preprocessor # directives found in the file $cppdefs_file # Any "#include" lines that appear in this file will not be affected # since they are required for finding include dependencies later # Create a tmp file containing the contents of $fsrc # These lines will have been preprocessed by prep_source so we want # to use this preprocessed code rather than whatever is in the original # disk file (ie in $fname) my $tmp_name = "tmp_find_depends_file_$stamp"; open(FSRC, ">$tmp_name") or die "Unable to open $tmp_name $!\n"; print FSRC "$fsrc\n"; close(FSRC); # Now that it exists we can change this to a absolute pathname # pipe_from_cpp expects an absolute path name $tmp_name = abs_path( $tmp_name ); # Note this will read the source from the file and overwrite anything # that was previously in $fsrc $fsrc = pipe_from_cpp( $tmp_name, $cppdefs_file ); # Clean up the tmp file unlink $tmp_name or die "Unable to unlink $tmp_name $!\n"; } # dpaths will contain a list of pathnames that contain subroutines, # modules or included files that the current file requires my @dpaths; # ipaths will contain a list of pathnames that contain just # included files that the current file requires my @ipaths; # mpaths will contain a list of pathnames that contain just # modules that the current file requires my @mpaths; # fpaths will contain a list of pathnames that contain just # functions that the current file requires my @fpaths; #=============== included files =================== # # fortran or cpp "include" files # # put everything found on a line after the include keyword into @inc_lines my @inc_lines = $fsrc =~ /^\s*#?\s*include(.*)$/mig; foreach my $line (@inc_lines) { # strip C style end of line comments $line =~ s@^(.*)/\*.*\*/\s*$@$1@; # strip ! delimited end of line comments $line =~ /!/ and $line =~ s/^([^!]*)!.*$/$1/; # strip # delimited end of line comments # $line =~ /#/ and $line =~ s/^([^#]*)#.*$/$1/; # strip leading and trailing whitespace $line =~ s/^\s*//; $line =~ s/\s*$//; next unless $line; if ($verbose > 3) {print "${bname}: inc_line:: $line\n"}; # remove any single or double quotes or parentheses or <> quotes $line =~ /^\s*'.*'\s*$/ and $line =~ s/^\s*'(.*)'\s*$/$1/; $line =~ /^\s*".*"\s*$/ and $line =~ s/^\s*"(.*)"\s*$/$1/; $line =~ /^\s*[(].*[)]\s*$/ and $line =~ s/^\s*[(](.*)[)]\s*$/$1/; $line =~ /^\s*<[^><]*>\s*$/ and $line =~ s/^\s*<([^><]*)>\s*$/$1/; # at this point line should contain the filename of the included file # however, it may be a full pathname, relative pathname or basename push @ipaths, $line unless grep /^$line$/, @ipaths; } # # update "call" directives # # put everything found on the line after the call keyword into @ucall_lines my @ucall_lines = $fsrc =~ /^[%*]call(.*)$/mig; foreach my $line (@ucall_lines) { if ($verbose > 2) {print "ucall_line:: $line\n"}; $line =~ s/^\s*//; # split on comma or white space ($aname) = split /\s*,\s*|\s+/, $line; $aname =~ s/^\s*//; $aname =~ s/\s*$//; # make all ucall names lower case and append the .cdk suffix $aname =~ tr/A-Z/a-z/; $aname .= ".cdk"; push @ipaths, $aname unless grep /^$aname$/, @ipaths; } # ensure an absolute path name for each element of ipaths that is # found to be a regular file in any directory found in path_list_all and # move non existant files to the not_found hash my @ip2 = (); foreach my $p (@ipaths) { if ($p =~ m'^/') { # the include file is an absoulte path name if (-f $p) { # if it exists add it to ip2 push @ip2, $p unless (grep /^$p$/, @ip2); } else { # if it does not exist then add it to not_found my $k = "include file: $p"; push @{$not_found{$k}}, $fname unless grep /^$k$/, @{$not_found{$k}}; } next; } # If the include file can be found in one of the dirs in path_list_all # then make it an absolute path name otherwise add to not_found foreach my $d (@path_list_all) { if (-f "$d/$p") { substr($p,0,0) = "$d/"; push @ip2, $p unless (grep /^$p$/, @ip2); last; } } unless ($p =~ m'^/') { # If it is not an absolute path name then add it to not_found my $k = "include file: $p"; push @{$not_found{$k}}, $fname unless grep /^$k$/, @{$not_found{$k}}; } } @ipaths = @ip2; undef @ip2; # Append includes to the child_of hash foreach my $p (@ipaths) { ($name, $path, $suffix) = fileparse($p,@suffix_list); unless (grep /^$name$suffix$/, @{ $child_of{$bname} }) { push @{ $child_of{$bname} }, $name.$suffix; } next if $scanned_by_find_dep{$p}; if ($verbose > 1) { printf "-i- %-12s %s\n","include",$p; } } if ($verbose > 3) { foreach my $k (keys %not_found) { print "$k ...NOT FOUND\n required by ",join("\n",@{$not_found{$k}}),"\n"; } } @dpaths = @ipaths; #=============== modules and subroutines =================== # # modules # # put everything found on a line after the use keyword into @module_lines my @module_lines = $fsrc =~ /^(?:\$|\s)\s*use\s(.*)$/mig; my @modules = (); foreach my $line (@module_lines) { if ($verbose > 3) {print "module_line:: $line\n"}; $line =~ s/^\s*//; # split on comma ($aname) = split /\s*,\s*/, $line; $aname =~ s/^ *//; $aname =~ s/ *$//; # The module name must contain white space or alphanumeric chars next unless $aname =~ /^(\w|\s)+$/; # make all module names lower case $aname =~ tr/A-Z/a-z/; push @modules, $aname unless grep /^$aname$/, @modules; } if ($verbose > 2) {print "modules used by ${bname}:: @modules\n"}; foreach my $dep (@modules) { $dep_count++; # Append modules to the child_of list unless (grep /^$dep$/, @{ $child_of{$bname} }) { push @{ $child_of{$bname} }, $dep; if ($verbose > 10) { print "level=$level ...appending $dep to child_of{$bname}\n"; print "child_of{$bname} = @{$child_of{$bname}}\n"; } } if (defined $mod_path{$dep}) { push @mpaths, $mod_path{$dep} unless grep /^$mod_path{$dep}$/, @mpaths; } if (exists $path_of{$dep}) {next}; if (defined $mod_path{$dep}) { # $dep exists in a disk file $path_of{$dep} = $mod_path{$dep} unless exists $path_of{$dep}; $src_of{$dep} = $source{$path_of{$dep}} unless exists $src_of{$dep}; # add this path to a list of dependent files to be scanned below push @dpaths, $path_of{$dep} unless grep /^$path_of{$dep}$/, @dpaths; if ($verbose > 1) { printf "-m- %-12s found in %s\n",$dep,$path_of{$dep}; } } else { # add to not_found my $k = " module: $dep"; push @{$not_found{$k}}, $fname unless grep /^$k$/, @{$not_found{$k}}; if ($verbose > 3) { printf "module %-20s not found ... used by %s\n",$dep,$fname; } } } push @dpaths, @mpaths if scalar @mpaths; # remove all single and double quoted strings from the fortran source code # There is a problem in rm_fortran_comments where a ! inside single quotes # is treated as a comment and removed, thus removing the second single quote. # When rm_quoted_strings is called with the string returned from rm_fortran_comments # eveything after the affected line is garbled. The temporary fix is to not call # rm_quoted_strings even though it works as advertised. The real fix needs # to be made in rm_fortran_comments. # $fsrc = rm_quoted_strings($fsrc, {VERBOSE=>2}); # # fortran subroutines # # put everything found on the line after the call keyword into @fcall_lines my @fcall_lines = $fsrc =~ /^(?:\$|\s|[0-9]).*[\s)]call\s(.*)$/mig; my @fcalls; foreach my $line (@fcall_lines) { if ($verbose > 3) {print "fcall_line:: $line\n"}; # remove "!" delimited comments $line = rm_comments_from_line($line); # take everything up to the first left parenthesis ($aname) = split '\(', $line; # strip leading and trailing whitespace $aname =~ s/^\s*//; $aname =~ s/\s*$//; next unless $aname; # The subroutine name must contain white space or alphanumeric chars next unless $aname =~ /^(\w|\s)+$/; # make all subroutine names lower case $aname =~ tr/A-Z/a-z/; push @fcalls, $aname unless grep /^$aname$/, @fcalls; } if ($verbose > 2) { print "subroutines called from ${bname}:: @fcalls\n"; } foreach my $dep (@fcalls) { $dep_count++; # Append fcalls to the child_of list unless (grep /^$dep$/, @{ $child_of{$bname} }) { push @{ $child_of{$bname} }, $dep; if ($verbose > 10) { print "level=$level ...appending $dep to child_of{$bname}\n"; print "child_of{$bname} = @{$child_of{$bname}}\n"; } } if (exists $path_of{$dep}) {next}; if (defined $sub_path{$dep}) { # $dep exists in a disk file $path_of{$dep} = $sub_path{$dep} unless exists $path_of{$dep}; $src_of{$dep} = $source{$path_of{$dep}} unless exists $src_of{$dep}; # add this path to a list of dependent files to be scanned below push @dpaths, $path_of{$dep} unless grep /^$path_of{$dep}$/, @dpaths; if ($verbose > 1) { printf "-s- %-12s found in %s\n",$dep,$path_of{$dep}; } } elsif ( exists $generic_procedure{$dep} ) { $path_of{$dep} = $generic_procedure{$dep}; $src_of{$dep} = $source{$path_of{$dep}} unless exists $src_of{$dep}; # add this path to a list of dependent files to be scanned below push @dpaths, $path_of{$dep} unless grep /^$path_of{$dep}$/, @dpaths; if ($verbose > 1) { printf "-s- generic procedure %-12s found in %s\n",$dep,$path_of{$dep}; } } else { # add to not_found my $k = " subroutine: $dep"; push @{$not_found{$k}}, $fname unless grep /^$k$/, @{$not_found{$k}}; if ($verbose > 3) { printf "subroutine %-16s not found ...called by %s\n",$dep,$fname; } } } # # fortran functions # foreach my $func (keys %func_path) { # $func will be the name of a function defined in the # source found in the file $func_path{$func} if ($fsrc =~ m@\b$func\s*\(@i) { push @fpaths, $func_path{$func}; } } push @dpaths, @fpaths if scalar(@fpaths); $scanned_by_find_dep{$fname}++; #DBG The following loops can be useful for determining where particular #DBG procedures from a particular file are used #DBG fpat is the file name pattern to match #DBG my $fpat = "cosp3"; #DBG foreach my $dep (keys %path_of) { #DBG next if $bname =~ /$fpat/; #DBG print "*** $bname requires module or subroutine $dep from $fpat\n" if $path_of{$dep} =~ /$fpat/; #DBG } #DBG foreach my $func (keys %func_path) { #DBG next if $bname =~ /$fpat/; #DBG if ($fsrc =~ m@\b$func( |\(|\n)@i) { #DBG print "*** $bname requires function $func from $fpat\n" if $func_path{$func} =~ /$fpat/; #DBG } #DBG } # scan each dependent file found for nested dependencies my @dp2; foreach my $path (@dpaths) { unless ($scanned_by_find_dep{$path}) { if ($verbose > 5) {print "scanning $path\n"}; push @dp2, find_depends({FILE => $path, SRC => $source{$path}, VERBOSE => $verbose, LEVEL => $level }); } } # add nested dependent files to dpaths foreach my $p (@dp2) { push @dpaths, $p unless grep /^$p$/, @dpaths; } # Populate *_depends with the unique set of dependent filepaths for $fname push @{$inc_depends{$fname}}, uniq_array( @ipaths ); push @{$mod_depends{$fname}}, uniq_array( @mpaths ); push @{$all_depends{$fname}}, uniq_array( @dpaths ); if ($verbose > 10) { foreach my $fpath ( sort keys %inc_depends ) { print "includes used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$inc_depends{$fpath}})),"\n"; } print "=========================================\n"; } if ($verbose > 10) { foreach my $fpath ( sort keys %mod_depends ) { print " modules used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$mod_depends{$fpath}})),"\n"; } print "=========================================\n"; } if ($verbose > 10) { foreach my $fpath ( sort keys %all_depends ) { print " files used by $fpath :: ",join(" ",map(m@^.*/(.*)$@,@{$all_depends{$fpath}})),"\n"; } print "=========================================\n"; } return @dpaths; } sub uniq_array { # Return the input array with all duplicate entries removed # Order is preserved # First seen of duplicates is used in output array use strict; my %seen = (); my @unique = grep { ! $seen{ $_ }++ } @_; return @unique; } sub isfreefmt { use strict; my $fname = shift; my $fsrc = shift; my $free = 0; my ($n, $p, $sfx) = fileparse("$fname", ('.f90', '.F90', '.f95', '.F95')); if ( $sfx ) { # The suffix is one of '.f90', '.F90', '.f95', '.F95' # Assume this is free format source $free = 1; } else { # Attempt to guess if the file is free format or fixed format my $decided = 0; if ( not $decided and $fsrc =~ /(^|\n)[^!]*&\n/si ) { # If any lines end with '&' and do not contain '!' then assume free format $free = 1; $decided = 1; } my $keywrds = '(program|subroutine|function|module)'; if ( not $decided and $fsrc =~ /(^|\n) {0,5}$keywrds/si ) { # If any of a few selected keywords are not preceeded by a new line # followed by at least 6 spaces then assume free format $free = 1; $decided = 1; } } return $free; } sub cat_fortran_lines { my ($fsrc, $OPTS) = @_; use strict; # Concatenate fortran continuation lines into single physical lines my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fname = ''; if (defined $OPTS->{FNAME}) {$fname = $OPTS->{FNAME}}; die "cat_fortran_lines: fname is not defined.\n" unless $fname; if ($allow_set_format) { my ($bname, $path, $sfx) = fileparse("$fname", ()); my $this_freefmt; if (exists $freefmt{"$bname$sfx"}) { $this_freefmt = $freefmt{"$bname$sfx"}; } else { $this_freefmt = isfreefmt($fname, $fsrc); } $FIXED_format = not $this_freefmt; } my $dbg = 0; my @llines = (); my $cont_line = 0; foreach my $line (split '\n',$fsrc) { if ($line =~ /^#/) { # copy C preprocessor directive lines without modification push @llines, $line; next; } if ($line =~ /\t/) { print "** WW ** The following line contains tabs in file $fname\n"; print "$line\n"; } # Remove any full line or end of line '!' delimited comments # This may be used on either fixed or free format source lines $line = rm_comments_from_line($line); if ($FIXED_format) { # Assume fixed format source code # Throw away fixed format comment lines next if $line =~ /^[Cc!]/; if (my ($cline) = $line =~ /^[^Cc*!%][^!]{4}[^ 0](.*)/) { # This is a continuation line if ($#llines == -1) { print "cat_fortran_lines: Syntax error in file $fname\n"; print "line = ::${line}::\n"; die "\n"; print "cline = ::${cline}::\n"; push @llines, $line; $dbg = 1; } else { $llines[$#llines] .= $cline; } } else { push @llines, $line; } } else { # Assume free format source code # Check for continuation lines if ($line =~ /&$/) { # This line ends with "&" so the following line is a continuation line $cont_line += 1; # Push this line onto llines but first strip the trailing "&" and any # leading "&" (preceeded by whitespace). # The leading "&" will appear when this is the second or greater # continuation line in a sequence of continuation lines $line =~ s/&$//; $line =~ s/^\s*&//; if ($cont_line > 1) { # This is the second or greater continuation line # Append this to the current line $llines[$#llines] .= $line; } else { # This is the first continuation line ...add a new line to llines push @llines, $line; } } else { if ($cont_line) { # This is a continuation line # Strip any leading "&" (and preceeding by whitespace) # The leading "&" will appear when this is the second or greater # continuation line in a sequence of continuation lines $line =~ s/^\s*&//; # Append this to the current line $llines[$#llines] .= $line; # Reset the continuation line counter $cont_line = 0; } else { # Otherwise simply push this line onto llines push @llines, $line; } } } } # Reset the format flag to indicate the default fixed format # unless the user has set the format on the command line $FIXED_format = $default_FIXED_format if $allow_set_format; # replace fsrc with the equivalent string except # that continuation lines are not wraped $fsrc = join "\n",@llines; $fsrc .= "\n"; if ($verbose > 1 or $dbg) { print "cat_fortran_lines: logical lines\n$fsrc\n"; } return $fsrc; } sub rm_fortran_comments { # Remove all comments and blank lines from fortran source code use strict; my $fsrc = shift; my $OPTS = shift; my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fname = ''; if (defined $OPTS->{FNAME}) {$fname = $OPTS->{FNAME}}; die "rm_fortran_comments: fname is not defined.\n" unless $fname; if ($allow_set_format) { my ($bname, $path, $sfx) = fileparse("$fname", ()); my $this_freefmt; if (exists $freefmt{"$bname$sfx"}) { $this_freefmt = $freefmt{"$bname$sfx"}; } else { $this_freefmt = isfreefmt($fname, $fsrc); } $FIXED_format = not $this_freefmt; } # Process the input string line by line my @lines = (); foreach my $line (split '\n',$fsrc) { if ($line =~ /^#/) { # Ignore C preprocessor directive lines push @lines, $line; next; } if ($FIXED_format) { # Remove lines that begin with "c" or "C" next if $line =~ /^[cC]/; } # Remove any full line or end of line '!' delimited comments $line = rm_comments_from_line($line); # Remove empty lines or lines containing only white space next if $line =~ /^\s*$/; push @lines, $line; } # Reset the format flag to indicate the default fixed format # unless the user has set the format on the command line $FIXED_format = $default_FIXED_format if $allow_set_format; # replace fsrc with the comments removed version $fsrc = join "\n",@lines; $fsrc .= "\n"; if ($verbose > 1) {print "String returned from rm_fortran_comments:\n$fsrc\n"}; return ($fsrc); } sub rm_comments_from_line { # Remove any '!' delimited comments from a single fortran source line # The input line may not contain any newlines use strict; my $line = shift; # Ensure no newlines exists die "rm_comments_from_line: The input -->\n$line\n<-- contains a newline\n" if $line =~ /\n/; # Store the comment string so that is may be returned, if requested my $comment = ''; # Do nothing unless the line contains a '!' character if ($line =~ /!/) { # Remove '!' delimited comments my $line_in = $line; # remove all single quoted strings on each line $line_in =~ s/'[^']*'//g; # remove all double quoted strings on each line $line_in =~ s/"[^"]*"//g; if ($line_in =~ /!/) { # If there is still a "!" after removing quoted segments then # detemine what part of the line is the comment ($comment) = $line_in =~ /(!.*)$/; # Remove this comment $line =~ s/^(.*)\Q$comment\E$/$1/; } } return wantarray ? ($line, $comment) : $line; } sub rm_quoted_strings {my ($fsrc, $OPTS) = @_; use strict; # Remove all single or double quoted strings from an input string my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; if ($verbose > 1) {print "String input to rm_quoted_strings:\n$fsrc\n"}; # remove all single quoted strings on each line $fsrc =~ s/'[^']*'//mg; # remove all double quoted strings on each line $fsrc =~ s/"[^"]*"//mg; if ($verbose > 1) {print "String returned from rm_quoted_strings:\n$fsrc\n"}; return ($fsrc); } sub rm_interface_block {my ($str, $OPTS) = @_; # Remove any interface blocks found in a fortran source file # but keep track of generic procedure names that are defined use strict; use Cwd qw(abs_path); my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fname = ''; if (defined $OPTS->{FNAME}) {$fname = $OPTS->{FNAME}}; # Make sure this is an absolute pathname if it points to a regular file $fname = abs_path($fname) if -f $fname; unless ($fname =~ m'^\s*/') { die "rm_interface_block: $fname is not a full path name\n"; } my $in = 0; my $tmp_str = ''; foreach my $line ( split("\n",$str) ) { if ( $line =~ /^\s*interface(\s*|$)/i ) { # Start of an interface block $in = 1; # Remove any '!' delimited comments from this line $line = rm_comments_from_line($line); # Look for a generic name following the interface keyword my ($gname) = $line =~ /^\s*interface\s(.*)/i; if ($gname) { unless ( $gname =~ /^\s*operator\s*\(?/i or $gname =~ /^\s*assignment\s*\(?/i ) { # This will be a generic procedure name $gname = lc($gname); unless ($generic_procedure{$gname}) { $generic_procedure{$gname} = $fname; } else { # If this generic procedure was already defined then define # the duplicate hash, assuming it has not also been defined $dup_generic_procedure{$gname} = $fname unless $dup_generic_procedure{$gname}; } } } if ($verbose > 10) { print "$fname line: $line\n"; } next; } if ( $in ) { # Set in false on the last line of this interface block $in = 0 if $line =~ /^\s*end\s*interface(\s*|$)/i; if ($verbose > 10) { print "$fname line: $line\n"; } next; } # Add this line to the output string $tmp_str .= "$line\n"; } $str = $tmp_str; undef $tmp_str; return ($str); } sub find_fortran_function {my ($OPTS) = @_; use strict; use Text::Tabs; # Find any fortran function definitions given the name of a file # that contains fortran source code or a preprocessed version thereof # This assumes fixed format source my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fsrc = ''; if (defined $OPTS->{SRC}) {$fsrc = $OPTS->{SRC}}; my $fname = ''; if (defined $OPTS->{FILE}) {$fname = $OPTS->{FILE}}; unless ($fsrc) { # If the source is not passed in via the SRC option # then attempt to read it from a file named $fname unless ($fname) { print "${Runame}::find_fortran_function"; print " Neither the SRC nor the FILE option has been specified\n"; die "Stopped"; } if (open(FSRC, "<$fname")) { $fsrc = ''; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, continuation lines, # interface blocks and possibly some cpp conditional blocks $fsrc = prep_source( $fsrc, $fname); } else { print "** WW ** ${Runame}::find_fortran_function\n"; warn " Cannot open file $fname\n "; } } # remove all single and double quoted strings from the fortran source code $fsrc = rm_quoted_strings($fsrc, {VERBOSE=>0}); # Keep these lines until the replacement line below has be thoroughly tested # regex for char or kind selector my $sre = '(?:\*\s*[0-9]+|[(][^(]*[)])?'; # regex for type specification my $type_spec_rea = '(?:integer|real|logical|character|complex)\s*' . $sre; my $type_spec_reb = '(?:byte|double\s*complex|double\s*precision)'; my @func_lines = $fsrc =~ /^\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*$type_spec_rea\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*$type_spec_reb\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*type\s*[(][^(]*[)]\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*recursive\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*pure\s*function(.*)$/mig; push @func_lines, $fsrc =~ /^\s*elemental\s*function(.*)$/mig; # my @func_lines = $fsrc =~ /^.*function(.*)$/mig; my @funcs = (); foreach my $line (@func_lines) { if ($verbose > 10) {print "func_line:: $line\n"}; # take everything up to the first left parenthesis $line =~ s/^\s*//; my ($aname) = split '\(', $line; next unless $aname; # then split on space ($aname) = split '\s', $aname; next unless $aname; $aname =~ s/^ *//; $aname =~ s/ *$//; # make all function names lower case $aname =~ tr/A-Z/a-z/; push @funcs, $aname unless grep /^$aname$/, @funcs; } if ($verbose > 3 and scalar(@funcs)) { print "functions found in file $fname\n@funcs\n"; } return @funcs; } sub find_fortran_subroutine {my ($OPTS) = @_; use strict; use Text::Tabs; # Find any fortran subroutine definitions given the name of a file # that contains fortran source code or a preprocessed version thereof # This assumes fixed format source my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fsrc = ''; if (defined $OPTS->{SRC}) {$fsrc = $OPTS->{SRC}}; my $fname = ''; if (defined $OPTS->{FILE}) {$fname = $OPTS->{FILE}}; unless ($fsrc) { # If the source is not passed in via the SRC option # then attempt to read it from a file named $fname unless ($fname) { print "${Runame}::find_fortran_subroutine"; print " Neither the SRC nor the FILE option has been specified\n"; die "Stopped"; } if (open(FSRC, "<$fname")) { $fsrc = ''; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, continuation lines, # interface blocks and possibly some cpp conditional blocks $fsrc = prep_source( $fsrc, $fname); } else { print "** WW ** ${Runame}::find_fortran_subroutine\n"; warn " Cannot open file $fname\n "; } } # remove all single and double quoted strings from the fortran source code $fsrc = rm_quoted_strings($fsrc, {VERBOSE=>0}); # put everything found on a line after the subroutine or entry keyword into @sub_lines my @sub_lines = $fsrc =~ /^\s*subroutine\s+(.*)$/mig; push @sub_lines, $fsrc =~ /^\s*recursive\s*subroutine\s+(.*)$/mig; push @sub_lines, $fsrc =~ /^\s*pure\s*subroutine\s+(.*)$/mig; push @sub_lines, $fsrc =~ /^\s*elemental\s*subroutine\s+(.*)$/mig; push @sub_lines, $fsrc =~ /^\s*entry\s+(.*)$/mig; my @subs = (); foreach my $line (@sub_lines) { if ($verbose > 10) {print "sub_line:: $line\n"}; # take everything up to the first left parenthesis $line =~ s/^\s*//; my ($aname) = split '\(', $line; # then split on space ($aname) = split '\s', $aname; $aname =~ s/^ *//; $aname =~ s/ *$//; # make all subroutine names lower case $aname =~ tr/A-Z/a-z/; push @subs, $aname unless grep /^$aname$/, @subs; } if ($verbose > 3 and scalar(@subs)) { print "subroutines found in file $fname\n@subs\n"; } return @subs; } sub find_fortran_module {my ($OPTS) = @_; use strict; use Text::Tabs; # Find any fortran module definitions given the name of a file # that contains fortran source code or a preprocessed version thereof # This assumes fixed format source my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fsrc = ''; if (defined $OPTS->{SRC}) {$fsrc = $OPTS->{SRC}}; my $fname = ''; if (defined $OPTS->{FILE}) {$fname = $OPTS->{FILE}}; unless ($fsrc) { # If the source is not passed in via the SRC option # then attempt to read it from a file named $fname unless ($fname) { print "${Runame}::find_fortran_module"; print " Neither the SRC nor the FILE option has been specified\n"; die "Stopped"; } if (open(FSRC, "<$fname")) { $fsrc = ''; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, continuation lines, # interface blocks and possibly some cpp conditional blocks $fsrc = prep_source( $fsrc, $fname); } else { print "** WW ** ${Runame}::find_fortran_module\n"; warn " Cannot open file $fname\n "; } } # remove all single and double quoted strings from the fortran source code $fsrc = rm_quoted_strings($fsrc, {VERBOSE=>0}); # put everything found on a line after the module keyword into @mod_lines my @mod_lines = $fsrc =~ /^\s*module\s+(.*)$/mig; my @mods = (); foreach my $line (@mod_lines) { if ($verbose > 10) {print "mod_line:: $line\n"}; # remove all spaces and the module name will be what is left $line =~ s/\s*//; # make all module names lower case $line =~ tr/A-Z/a-z/; push @mods, $line unless grep /^$line$/, @mods; } if ($verbose > 3 and scalar(@mods)) { print "modules found in file $fname\n@mods\n"; } return @mods; } sub find_fortran_common {my ($OPTS) = @_; use strict; use Text::Tabs; # Find any fortran common definitions given the name of a file # that contains fortran source code or a preprocessed version thereof # This assumes fixed format source my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fsrc = ''; if (defined $OPTS->{SRC}) {$fsrc = $OPTS->{SRC}}; my $fname = ''; if (defined $OPTS->{FILE}) {$fname = $OPTS->{FILE}}; unless ($fsrc) { # If the source is not passed in via the SRC option # then attempt to read it from a file named $fname unless ($fname) { print "${Runame}::find_fortran_common"; print " Neither the SRC nor the FILE option has been specified\n"; die "Stopped"; }; if (open(FSRC, "<$fname")) { $fsrc = ''; # expand tabs as each line is read while () {$fsrc .= expand($_)}; close(FSRC); # Preprocess the source just read to remove comments, continuation lines, # interface blocks and possibly some cpp conditional blocks $fsrc = prep_source( $fsrc, $fname); } else { print "** WW ** ${Runame}::find_fortran_common\n"; warn " Cannot open file $fname\n "; } } # remove all single and double quoted strings from the fortran source code $fsrc = rm_quoted_strings($fsrc, {VERBOSE=>0}); # put everything found on a line after the common keyword into @com_lines my @com_lines = $fsrc =~ /^ [0-9 ]{4}\s*common(.*)$/mig; my @coms = (); foreach my $line (@com_lines) { if ($verbose > 10) {print "com_line:: $line\n"}; # extract the common block name my $aname = ''; ($aname) = $line =~ m#^\s*/([^/]*)/#; # set aname = BLANK_COMMON if this is blank common # TODO: BLANK_COMMON does not make it into the commons file $aname = 'BLANK_COMMON' unless $aname; $aname =~ s/^ *//; $aname =~ s/ *$//; # make all common names lower case $aname =~ tr/A-Z/a-z/; push @coms, $aname unless grep /^$aname$/, @coms; } if ($verbose > 3 and scalar(@coms)) { print "common blocks found in file $fname\n@coms\n"; } return @coms; } sub pipe_from_cpp { # Remove all #if ... #endif blocks from the disk file found in $abspath # removing (or not) conditional code as determined by the preprocessor # directives found in the file $cppdefs # Any "#include" lines that appear in this file will not be affected but # all other cpp directives will be processed and removed # The "#include" lines are required for finding include dependencies later use strict; use Text::Tabs; use Cwd qw(cwd abs_path); my $abspath = shift; my $cppdefs = shift; # Sanity checks die "abspath is undefined. Stopped" unless $abspath; die "cppdefs is undefined. Stopped" unless $cppdefs; die "abspath = $abspath is missing or empty. Stopped" unless -s $abspath; die "cppdefs = $cppdefs is missing or empty. Stopped" unless -s $cppdefs; # Determine the full pathname for cppdefs my $abscpp = abs_path( $cppdefs ); # Save the name of the current working directory my $CWD = cwd(); my ($name, $path, $sfx) = fileparse("$abspath", ()); my $dir = abs_path( $path ); chdir $dir or die "$! Stopped"; my $fsrc = ""; # Comment out all "#include" lines before running cpp # Note that since we comment out all #include's there is no need to # run this in the dir where those included file would live my $sed_prog = 's/^\(# *include *["<][^C][^P][^P][-A-Za-z_0-9 ].*\)$/c3-4-1\1/'; # The cpp command line options "-E -fdirectives-only" imply preprocessing is limited # to the handling of directives such as "#define", "#ifdef", and "#error" if ( $mach_type =~ "aix" ) { open(PIPE, "sed \'$sed_prog\' $abspath|cat $abscpp -|cpp -P - -|") or die "$! Stopped"; } else { my $sed_cpp = ':a; s%(.*)/\*.*\*/%\1%; ta; /\/\*/ !b; N; ba'; # remove C-comments open(PIPE, "sed \'$sed_prog\' $abspath|cat $abscpp -|cpp -nostdinc -P -E -fdirectives-only - - | sed -r \'$sed_cpp\' |") or die "$! Stopped"; } while () { $fsrc .= expand($_) }; close(PIPE); chdir $CWD or die "$! Stopped"; # Now uncomment the "#include" lines so we can use them later $fsrc =~ s/^c3-4-1(# *include *["<][A-Za-z_0-9 ].*)$/$1/mg; return $fsrc; } sub rm_undef_blocks {my ($str, $OPTS) = @_; # Remove any code within specified %IF...%ENDIF update directives use strict; # if there are no %IF update directives # then simply return the input string return ($str) unless ($str =~ /^\s*[%*]\s*if/im); my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $undefs; if (defined $OPTS->{UNDEFS}) {$undefs = $OPTS->{UNDEFS}}; # if there are no undefs then simply return the input string return ($str) unless (scalar keys %$undefs); my $fname = ''; if (defined $OPTS->{FNAME}) {$fname = $OPTS->{FNAME}}; my $subOPTS = {VERBOSE=>$verbose, UNDEFS=>$undefs, FNAME=>$fname}; my @S = split_on_delim($str, $subOPTS); if ($verbose > 10) { print "String returned from rm_undef_blocks:\n",join '',@S,"\n"; } return (join '',@S); } sub split_on_delim { use strict; # return a list containing subsections of the input string # split on the delimiters $if and $fi my $str = shift; my $OPTS = shift; my @ret; my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; my $fname = ''; if (defined $OPTS->{FNAME}) {$fname = $OPTS->{FNAME}}; my $undefs; if (defined $OPTS->{UNDEFS}) {$undefs = $OPTS->{UNDEFS}}; my $subOPTS = {VERBOSE=>$verbose, UNDEFS=>$undefs, FNAME=>$fname}; die "Please do not call split_on_delim ...yet.\n"; # define regexes to find the %IF and %ENDIF update lines # Note that matches will start with a newline but not end with one my $if = '(^|\n)[%*][Ii][Ff]\s*[^\n]+'; my $fi = '\n[%*][Ee][Nn][Dd][Ii][Ff][^\n]*'; my $retain = sub { # Determine whether a conditional block is to be kept # based on the truth of the first %IF... directive my $mat = shift; # a string delimited by $if and $fi is input # extract the first %IF... condition my ($ifstr) = $mat =~ /($if)/si; die "failed to match start delimiter\n" unless ($ifstr); # strip leading %IF $ifstr =~ s/^\s*[%*]IF\s*//si; if ($verbose>10) {print "ifstr: $ifstr\n"}; # unless a token in the undefs hash matches one # on the %IF line return a true value my $hasundef = 0; foreach (keys %$undefs) { $ifstr =~ /\b$_\b/si and do {$hasundef = 1; last}; } return 1 unless $hasundef; # determine the truth value of this condition my $def=1; my $and=0; my $or=0; my $ifval=-1; foreach (split ',',$ifstr) { if ($verbose>10) {print "$_\n"}; /^\s*DEF/si and do {$def=1; next}; /^\s*-DEF/si and do {$def=0; next}; /^\s*AND/si and do {$and=1; next}; /^\s*OR/si and do {$or=1; next}; s/\s*//g; # remove whitespace tr/a-z/A-Z/; # ensure upper case # assume the token is defined unless it is found in the undefs hash my $tokval = 1; $tokval = 0 if (exists $$undefs{$_}); $tokval = $def==0 ? 1-$tokval : $tokval; if ($ifval < 0) { # this is the first time through $ifval = $tokval; } else { if ($and) {$ifval = $ifval * $tokval; $and=0} elsif ($or) {$ifval = $ifval > $tokval ? $ifval : $tokval; $or=0} else {die "Malformed update directive found in ${fname}:\n%IF $ifstr\n "}; } } die "***ERROR*** Problem in $fname with update directive:\n%IF $ifstr\n " if $ifval<0; if ($verbose>10) {print "${fname}: %IF $ifstr ...$ifval\n"}; return $ifval; }; # Create a DelimMatch object # my $mc = $DelimMatch::new "DelimMatch" $if,$fi; # my $post = $str; # while (my $match = $mc->match($post)) { # # find all matches # if ($verbose>10) {print "\nmatch:$match\n"}; # my $pre = $mc->pre_matched(); # push @ret, $pre if $pre; # $post = $mc->post_matched(); # if (&$retain($match)) { # # if this block is to be retained then strip the first and last delimiter # # and recursively call split_on_delim with the stripped match # my ($d1) = $match =~ /^($if)/s; # $d1 =~ s/\n$//; # my ($d2) = $match =~ /($fi)$/s; # $d2 =~ s/\n$//; # push @ret, $d1; # push @ret, split_on_delim($mc->strip_delim($match), $subOPTS); # push @ret, $d2; # } # } # if ($post) { # my @T; # foreach ($post =~ /($if|$fi)/sig) {push @T,$_ if $_}; # die "There are unmatched %IF..%ENDIF pairs in ${fname}:@T\n" # if scalar(@T); # } # push @ret, $post; # return the list of sub strings with undefined blocks removed return @ret; } ########################################################################### #--- BEGIN --- code in common with up2cpp ########################################################################### sub model_job_to_cpp_sizes { # Read a model job string to extract parmsub/update info and the CPP_I section # This info is used to create updates_file, cppdefs_file and/or sizes_file # if they do not already exists. # As a side effect the parmsub hash is defined and will contain all parmsub # parameters that were defined in the input model job string use strict; my $model_job_file = shift; # Read the first part of the model job string into memory # Stop reading at the end of the first job in the string # For a "normal" model job string this will include the entire parmsub # section as well as any updates (script updates are ignored) my $shlines = ''; my $updates = ''; my $update_type = ''; my @here_doc; open (FILE, "<$model_job_file") || die "$!"; while () { # Look for lines indicating the start of an update section if ( /^###[#\s]*update\s+/ ) { # This is the first line of an update section # Determine the type of updates (e.g. script, model, sub ...) ($update_type) = /^###[#\s]*update\s+(\w+).*$/; } # Process lines indicating the start of a here document separately if ( my ($end_here) = m!^\s*cat.*<<\s*('[^']*'|"[^"]*"|[\w\.\$/-]+)! ) { # This is the start of a here document # Determine the name of this here document my ($name_here) = m!^\s*cat.*>>?\s*('[^']*'|"[^"]*"|[\w\.\$\{\}\=\:\+/-]+)!; # Strip any quotes from the name $name_here =~ s/^\s*'([^']+)'\s*$/$1/; $name_here =~ s/^\s*"([^"]+)"\s*$/$1/; # Strip any quotes from the end delimiter $end_here =~ s/^\s*'([^']+)'\s*$/$1/; $end_here =~ s/^\s*"([^"]+)"\s*$/$1/; my %hdoc; $hdoc{name} = $name_here; $hdoc{end} = $end_here; # Add info about this here doc to the @here_doc list push @here_doc, \%hdoc; if ( $name_here eq "Model_Input" ) { # Ignore lines that start a here document # but only for the Model_Input here doc next; } } # Process lines indicating the end of a here document separately if ( scalar(@here_doc) ) { my $name_here = $here_doc[$#here_doc]->{name}; my $end_here = $here_doc[$#here_doc]->{end}; if ( /^$end_here\s*$/ ) { # Remove this delimiter from the here_doc stack pop @here_doc; if ( $name_here eq "Model_Input" ) { # Set update_type to null at the end of the Model_Input here doc since # this is the end of all Model_Input content, including updates $update_type = ""; # Skip the line containing the end delimiter # of the "Model_Input" here doc next; } } } # Append this line to either the source (parmsub) or update strings if ( $update_type ) { # This line is within an update section unless ( $update_type =~ /^\s*script\s*$/i ) { # Add this line to the updates string, ignoring script updates # unless a file named betapath* in sourced $updates .= expand($_) unless /^\s*\.\s+betapath/; } } else { # Add this to the file string # Removing ". script" lines may cause a problem in an update section where # there is a continuation line and the continuation character is "." # We must remove these lines only for shell script fragments $shlines .= expand($_) unless /^\s*\.\s+[^\s]+[\s;]*$/; } # Only read, at most, the first job from this file last if /^# *end_of_job\s*$/; } close FILE; warn "** WW ** No update sections were found in $model_job_file. This may not be a model job string.\n" unless $updates; # Extract all shell variables found in this script and assign them to parmsub my ($parmsub_ref, $script, $CPP_I) = shvals( $shlines ); die "Unable to read any variable defs from $model_job_file.\n" unless $parmsub_ref; %parmsub = %{$parmsub_ref}; undef $parmsub_ref; # Create a file containing all parmsub parameters found in this model string unless ($parmsub_file) { $parmsub_file = $parmsub{runid} ? "parmsub_$parmsub{runid}": "parmsub_$stamp"; } if ( $parmsub_file ) { open( PARMSUB, ">$parmsub_file") or die "$!"; foreach my $key ( sort keys %parmsub ) { print PARMSUB "$key = $parmsub{$key}\n"; } close(PARMSUB); } if ( $set_by_usr{parmsub_file} ) { # If the user has supplied a parmsub file name on the command line then # assume that this file is all they are interested in and exit here exit 0; } # Use these parmsub definitions to set certain global variables unless ( $set_by_usr{xlfqinitauto} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{noxlfqinitauto} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{noxlfqinitauto} =~ /^(no|off)$/i ) { $with{xlfqinitauto} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlfqinitauto} = 2; } elsif ( $parmsub{noxlfqinitauto} =~ /^(yes|on)$/i ) { $with{xlfqinitauto} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlfqinitauto} = 2; } } } unless ( $set_by_usr{xlfimp} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{noxlfimp} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{noxlfimp} =~ /^(no|off)$/i ) { $with{xlfimp} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlfimp} = 2; } elsif ( $parmsub{noxlfimp} =~ /^(yes|on)$/i ) { $with{xlfimp} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlfimp} = 2; } } } unless ( $set_by_usr{xlflarge} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{noxlflarge} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{noxlflarge} =~ /^(no|off)$/i ) { $with{xlflarge} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlflarge} = 2; } elsif ( $parmsub{noxlflarge} =~ /^(yes|on)$/i ) { $with{xlflarge} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{xlflarge} = 2; } } } unless ( $set_by_usr{xlfversion} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{xlf12104} ) { # Set true if one of yes|on, otherwise do nothing (ie use the default value) if ( $parmsub{xlf12104} =~ /^(yes|on)$/i ) { $with{xlfversion} = "xlf12104"; $set_by_usr{xlfversion} = 2; } } if ( $parmsub{xlf13108} ) { # Set true if one of yes|on, otherwise do nothing (ie use the default value) if ( $parmsub{xlf13108} =~ /^(yes|on)$/i ) { $with{xlfversion} = "xlf13108"; $set_by_usr{xlfversion} = 2; } } if ( $parmsub{xlf14101} ) { # Set true if one of yes|on, otherwise do nothing (ie use the default value) if ( $parmsub{xlf14101} =~ /^(yes|on)$/i ) { $with{xlfversion} = "xlf14101"; $set_by_usr{xlfversion} = 2; } } } unless ( $set_by_usr{mpi} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{nnode_a} ) { # nnode_a is the number of mpi tasks assigned to the atm if ( $parmsub{nnode_a} > 1 ) { $with{mpi} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{mpi} = 2; } } } unless ( $set_by_usr{coupled} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{coupled} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{coupled} =~ /^(no|off)$/i ) { $with{coupled} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{coupled} = 2; } elsif ( $parmsub{coupled} =~ /^(yes|on)$/i ) { $with{coupled} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{coupled} = 2; # Also use mpi when coupled is true unless ( $set_by_usr{mpi} ) { # Do this only if mpi was not set on the command line or set above $with{mpi} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{mpi} = 2; } } } } unless ( $set_by_usr{omp} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{openmp} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{openmp} =~ /^(no|off)$/i ) { $with{omp} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{omp} = 2; } elsif ( $parmsub{openmp} =~ /^(yes|on)$/i ) { $with{omp} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{omp} = 2; } } } unless ( $set_by_usr{float1} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{float1} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{float1} =~ /^(no|off)$/i ) { $with{float1} = 0; $with{float2} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{float1} = 2; } elsif ( $parmsub{float1} =~ /^(yes|on)$/i ) { $with{float1} = 1; $with{float2} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{float1} = 2; } } } unless ( $set_by_usr{float2} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{float2} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{float2} =~ /^(no|off)$/i ) { $with{float1} = 1; $with{float2} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{float2} = 2; } elsif ( $parmsub{float2} =~ /^(yes|on)$/i ) { $with{float1} = 0; $with{float2} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{float2} = 2; } } } unless ( $set_by_usr{p5lib} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{p5lib} ) { # If not one of no|yes|on|off then do nothing (ie use the default value) if ( $parmsub{p5lib} =~ /^(no|off)$/i ) { $with{p5lib} = 0; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{p5lib} = 2; } elsif ( $parmsub{p5lib} =~ /^(yes|on)$/i ) { $with{p5lib} = 1; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{p5lib} = 2; } } } unless ( $set_by_usr{user_source} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{user_source} ) { # Assign this to an internal variable $ocn_user_source = $parmsub{user_source}; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{user_source} = 2; } } unless ( $set_by_usr{modver} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{modver} ) { # Assign this to an internal variable $modver = $parmsub{modver}; $atmver = $parmsub{modver}; # Ensure the corresponding lsmod dir exists if ( $verbose > 2 ) { unless ( -d "$CCRNSRC/source/lsmod/agcm/$modver" ) { warn "** WW ** modver = $modver found in $model_job_file but $CCRNSRC/source/lsmod/agcm/$modver is not a directory\n" } } # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{modver} = 2; $set_by_usr{atmver} = 2; } } unless ( $set_by_usr{ocnver} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{cgcm_source} ) { # cgcm_source will contain an absolute directory name indicating where the ocean source lives # This program reads ocean source from a git repository where a tagged version should exist # that contains this same ocean source as appears in this directory. # The name of the tag will be the last part of the directory name. my @d = split(/\//, $parmsub{cgcm_source}); # Assign this to an internal variable $ocnver = $d[$#d]; # Reassign certain values so that the correct git tag is associated with older dir names $ocnver = "canesm1_ocn" if $ocnver eq "can_esm1"; $ocnver = "canesm2_v1_ocn" if $ocnver eq "can_esm2_b1"; $ocnver = "canesm2_v2_ocn" if $ocnver eq "can_esm2_b2"; $ocnver = "canesm2_v3_ocn" if $ocnver eq "can_esm2_b3"; $ocnver = "canesm2_v4_ocn" if $ocnver eq "can_esm2_v4"; $ocnver = "canesm2_v5_ocn" if $ocnver eq "can_esm2_v5"; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{ocnver} = 2; } } unless ( $set_by_usr{cancpl_ver} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{cancpl_ver} ) { # Assign this to an internal variable $cancpl_ver = $parmsub{cancpl_ver}; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{cancpl_ver} = 2; } } unless ( $set_by_usr{cancpl_repo} ) { # If this was not set on the command line then look for a relevant parmsub parameter if ( $parmsub{cancpl_repo} ) { # Assign this to an internal variable $cancpl_repo = $parmsub{cancpl_repo}; # Assign set_by_usr a value of 2 to indicate this was set from a file $set_by_usr{cancpl_repo} = 2; } } unless ( $updates_file ) { # If the user has not supplied an updates file then create one # using the updates section found in the user supplied model_job_file if ( $updates ) { # Don't bother unless updates is present in the model_job_file $updates_file = $parmsub{runid} ? "updates_$parmsub{runid}": "updates_$stamp"; open( UPDATES, ">$updates_file") or die "$!"; print UPDATES "$updates\n"; close(UPDATES); } } unless ( $cppdefs_file ) { # If the user has not supplied a cppdefs file then create one # using the CPP_I section found in the user supplied model_job_file if ( $CPP_I ) { # Don't bother unless CPP_I is present in the model_job_file $cppdefs_file = $parmsub{runid} ? "CPP_I_$parmsub{runid}": "CPP_I_$stamp"; open( CPPDEFS, ">$cppdefs_file") or die "$!"; print CPPDEFS "$CPP_I\n"; close(CPPDEFS); } } unless ( $sizes_file ) { # Create a sizes file from info in this model_job file # This requires 2 programs to be on the users path # gcmparm_input # gcmparm # If either of these are missing one of the following system calls will fail # Create a disk file containing the parmsub section # with any CPP_I section removed my $parmsub_tmp = "parmsub_$stamp"; open( PARMTMP, ">$parmsub_tmp") or die "$!"; print PARMTMP "$script\n"; close(PARMTMP); # This command will create a file named gcmparmin_tmp my $gcmparmin_tmp = "gcmparmin_$stamp"; syscmd( "gcmparm_input $parmsub_tmp outfile=$gcmparmin_tmp" ); # Remove the temporary parmsub_tmp file unlink $parmsub_tmp or die "Unable to remove $parmsub_tmp. Stopped"; # This command will use gcmparmin_tmp to create the sizes file $sizes_file = $parmsub{runid} ? "sizes_$parmsub{runid}": "sizes_$stamp"; syscmd( "gcmparm $sizes_file < $gcmparmin_tmp" ); # Remove the temporary gcmparmin_tmp file unlink $gcmparmin_tmp or die "Unable to remove $gcmparmin_tmp. Stopped"; # Add a value for NRFP to the sizes file my $NRFP = $parmsub{NRFP} ? $parmsub{NRFP} : 1; syscmd( "echo \"NRFP = $NRFP,\" >> $sizes_file" ); # These variables are added to the sizes file only if they exist in the model string if ( $parmsub{ntld} ) { syscmd( "echo \"NTLD = $parmsub{ntld},\" >> $sizes_file" ) } if ( $parmsub{ntlk} ) { syscmd( "echo \"NTLK = $parmsub{ntlk},\" >> $sizes_file" ) } if ( $parmsub{ntwt} ) { syscmd( "echo \"NTWT = $parmsub{ntwt},\" >> $sizes_file" ) } if ( $parmsub{iflm} ) { syscmd( "echo \"IFLM = $parmsub{iflm},\" >> $sizes_file" ) } if ( $parmsub{initpool} ) { syscmd( "echo \"INITPOOL = $parmsub{initpool},\" >> $sizes_file" ) } if ( $parmsub{lndcvrmod} ) { syscmd( "echo \"LNDCVRMOD = $parmsub{lndcvrmod},\" >> $sizes_file" ) } if ( $parmsub{lndcvr_offset} ) { syscmd( "echo \"LNDCVR_OFFSET = $parmsub{lndcvr_offset},\" >> $sizes_file" ) } } return 1; } sub shvals { # Given a file containing valid shell script (except possibly containing a # CPP_I section) return a hash of all variable definitions found in that script. use strict; my $script_in = shift; my $read_verbatim = shift; my $strip_quotes = shift; my %VAR; $read_verbatim = 0 unless defined $read_verbatim; $strip_quotes = 1 unless defined $strip_quotes; # Remove any CPP_I section from this script # The input string without any CPP_I section is returned in $script my ($CPP_I, $script) = rip_cpp_i($script_in); # Remove all shell comment lines and any reference to "sourced" # external files found in this script my $tmp_script = ""; foreach (split /\n/,$script) { # Retain the shebang line, if any, # and throw away all comment lines unless (/^\s*#!/) {next if /^\s*#/} # Remove commands that source scripts via ". script" from each line s/^\s*\.\s+[^\s;]+[\s;]*$//; #lines containing a single ". file" s/^\s*\.\s+[^\s;]+;/ : ;/; #lines beginning with ". file" s/;\s*\.\s+[^\s;]+/; : /g; #lines containing "; . file" $tmp_script .= "$_\n"; } $script = $tmp_script; undef $tmp_script; if ($read_verbatim) { # Do not source input but read var=val definitions verbatim. # This may be useful when the input is not a shell script or it # is undesireable to execute it as a shell script. my @defs; foreach (split /\n/, $script) { next if /^\s*#/; # ignore comment lines next unless /=/; # ignore lines without any parameter defs s/^([^#]*).*/$1/; # strip trailing comments # values are backtic delimited my $bt = q@`[^`]*`@; # values are single quote delimited my $sq = q@'[^']*'@; # values are double quote delimited my $dq = q@"[^"]*"@; # values are terminated by a semi colon or white space my $sw = q@[^\s;]*?(?=[\s;])@; # null values my $nv = '\s*;'; push @defs, /\b(\w+=(?:$bt|$sq|$dq|$sw|$nv))/g; } foreach (@defs) { my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; $val =~ s/^\s+//; # strip leading white space from value $val =~ s/\s+$//; # strip trailing white space from value $val =~ s/^"(.*)"$/$1/; # strip double quotes from value $val =~ s/^'(.*)'$/$1/; # strip single quotes from value # add or replace this variable in the param hash $VAR{$var} = $val; } } else { # Source input in a shell then extract variable definitions # Get the current environment # Set IFS explicitly since it will usually contain a newline # which will confuse the following loop because it expects # the var=val to be on a single line. chomp(my @sh_env = `IFS=' '; set`); die "*** ERROR *** executing shell set command\n" if $?; my %curr_env; foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; # do not add this var to the curr_env if # it was previously defined for $VAR next if exists $VAR{$var}; $curr_env{$var} = $val; } # Create a temporary file containing a preprocessed # version of the input script chomp(my $script_file = `echo "shvar_script_$$"`); if (open(SH_SCRIPT, ">./$script_file")) { foreach (split /\n/,$script) { print SH_SCRIPT "$_\n"; } close(SH_SCRIPT); if ($verbose > 5) {print "Created $script_file\n"}; } else { die "shvals: Cannot open file $script_file for output.\n Stopped"; } if ($verbose > 10) { print "PREPROCESSED SCRIPT: $script_file\n"; print `cat $script_file`; } # Now get the environment including the input script variables and # add variables to the $VAR hash that were defined in the input # script but did not exist in the current default environment. @sh_env = (); @sh_env = syscmd( "IFS=' '; . ./$script_file >/dev/null; set" ); syscmd( "rm -f $script_file" ); foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; next if exists $curr_env{$var}; if ($verbose > 0) { if (exists $VAR{$var}) { if (defined $VAR{$var}) { unless ($VAR{$var} eq $val) { if ( $verbose > -1 ) { print "Parameter $var found in script was previously defined\n"; print "The previous value ($VAR{$var}) will be replaced by $val\n"; } } } } } if ($strip_quotes) { # Remove single quotes added by the shell $val =~ s/^\s*'(.*?)'\s*$/$1/; } $VAR{$var} = $val; if ($verbose > 5) {print "shvals: ${var}=$val\n"} } } if ( $verbose > 10 ) { foreach (sort keys %VAR) { print "shvals: $_ = $VAR{$_}\n"; } } return wantarray ? (\%VAR, $script, $CPP_I) : \%VAR; } sub rip_cpp_i { # Extract any CPP_I definition that may appear in this job # Return 2 strings: # 1) the CPP_I section # 2) the input job string with the CPP_I section removed use strict; use Text::Balanced qw(extract_tagged); my $job = shift; # Define a set of regexes that will match the first and last lines # of the CPP_I section as well as any text found in the input job # string that is before the first line of the CPP_I section my $start_cpp = qr/(?:^|\n)[ \t]*## *CPP_I_START *\n/si; my $stop_cpp = qr/[ \t]*## *CPP_I_END *\n/si; my $pfx = qr/.*?(?=(?:^|\n)[ \t]*## *CPP_I_START)/si; if ($verbose > 10) { print "start_cpp = $start_cpp\n"; print "stop_cpp = $stop_cpp\n"; print " pfx = $pfx\n"; } my @cpp_i = extract_tagged($job,$start_cpp,$stop_cpp,$pfx); print "extract_tagged: ",$@,"\n" if scalar($@); my $CPP_I = $cpp_i[4]; if ($verbose > 1 and $CPP_I) {print "CPP_I section:\n$CPP_I\n"} print "CPP_I is missing from the parmsub section\n" unless $CPP_I; my $job_out = $cpp_i[2] . "\n" . $cpp_i[1] . "\n"; if ($verbose > 10) { use Data::Dumper 'Dumper'; print Dumper [ @cpp_i ]; } return wantarray ? ($CPP_I, $job_out) : $CPP_I; } ########################################################################### #--- END --- code in common with up2cpp ########################################################################### #xxx package DelimMatch; #xxx #xxx use strict; #xxx use vars qw($VERSION @ISA @EXPORT $case_sensitive); #xxx #xxx require 5.000; #xxx require Exporter; #xxx require AutoLoader; #xxx #xxx @ISA = qw(Exporter AutoLoader); #xxx @EXPORT = qw(); #xxx $VERSION = '1.06'; #xxx #xxx sub new { #xxx my $type = shift; #xxx my $start = shift; #xxx my $end = shift || $start; #xxx my $esc = shift; #xxx my $dblesc= shift; #xxx my $class = ref($type) || $type; #xxx my $self = bless {}, $class; #xxx local $_ = "no -w warning in evals now"; #xxx #xxx eval "/$start/" if defined($start); #xxx eval "/$end/" if !$@ && defined($end); #xxx #xxx $self->{'STARTREGEXP'} = $start; # a regexp #xxx $self->{'ENDREGEXP'} = $end; # a regexp #xxx $self->{'QUOTE'} = {}; # a hash of regexp, start => end #xxx $self->{'ESCAPE'} = ""; # a regexp set of chars #xxx $self->{'DBLESCAPE'} = ""; # a regexp set of chars #xxx #xxx $self->{'ERROR'} = $@; # false if OK #xxx $self->{'DEBUG'} = 0; # boolean #xxx $self->{'CASESENSE'} = 0; # boolean #xxx $self->{'FORCESLOW'} = 0; # boolean #xxx $self->{'KEEP'} = 1; # boolean #xxx $self->{'RETURNDELIM'} = 1; # boolean #xxx #xxx $self->{'BUFFER'} = ""; #xxx $self->{'PRE'} = ""; #xxx $self->{'MATCH'} = ""; #xxx $self->{'POST'} = ""; #xxx #xxx $self->escape($esc) if $esc; #xxx $self->double_escape($dblesc) if $dblesc; #xxx $self->quote(@_) if @_; #xxx #xxx return $self; #xxx } #xxx #xxx sub delim { #xxx my $self = shift; #xxx my $start = shift; #xxx my $end = shift || $start; #xxx my $curs = $self->{'STARTREGEXP'}; #xxx my $cure = $self->{'ENDREGEXP'}; #xxx local $_ = "no -w warning in evals now"; #xxx #xxx eval "/$start/" if defined($start); #xxx eval "/$end/" if !$@ && defined($end); #xxx #xxx $self->{'ERROR'} = $@; # false if OK #xxx $self->{'STARTREGEXP'} = $start; #xxx $self->{'ENDREGEXP'} = $end; #xxx #xxx if ($self->{'DEBUG'}) { #xxx print "DELIM : $start, $end"; #xxx print ": ", $self->{'ERROR'} if $self->{'ERROR'}; #xxx print "\n"; #xxx } #xxx #xxx return ($curs, $cure); #xxx } #xxx #xxx sub quote { #xxx my $self = shift; #xxx my (%oldq) = %{$self->{'QUOTE'}}; #xxx local $_ = "no -w warning in evals now"; #xxx my ($key, $val); #xxx #xxx $key = shift @_; #xxx #xxx if (!defined($key)) { #xxx $self->{'QUOTE'} = {}; #xxx } else { #xxx while ($key) { #xxx $val = shift @_ || $key; #xxx #xxx eval "/$key/" if defined($key); #xxx eval "/$val/" if !$@ && defined($val); #xxx $self->{'ERROR'} = $@ if $@; #xxx #xxx if ($self->{'DEBUG'}) { #xxx print "QUOTE : $key = $val"; #xxx print ": ", $self->{'ERROR'} if $self->{'ERROR'}; #xxx print "\n"; #xxx } #xxx #xxx $self->{'QUOTE'}->{$key} = $val; #xxx $key = shift @_; #xxx } #xxx } #xxx #xxx return %oldq; #xxx } #xxx #xxx sub escape { #xxx my $self = shift; #xxx my $esc = shift; #xxx my $curesc = $self->{'ESCAPE'}; #xxx local $_ = "no -w warning in evals now"; #xxx #xxx $esc = '[' . quotemeta($esc) . ']' if defined($esc) && ($esc ne ""); #xxx #xxx if (defined($esc) && ($esc ne "")) { #xxx eval "/$esc/"; #xxx $self->{'ERROR'} = $@ if $@; #xxx } #xxx #xxx $self->{'ESCAPE'} = $esc; #xxx #xxx if ($self->{'DEBUG'}) { #xxx print "ESCAPE: $esc"; #xxx print ": ", $self->{'ERROR'} if $self->{'ERROR'}; #xxx print "\n"; #xxx } #xxx #xxx return $curesc; #xxx } #xxx #xxx sub double_escape { #xxx my $self = shift; #xxx my $esc = shift; #xxx my $curesc = $self->{'DBLESCAPE'}; #xxx local $_ = "no -w warning in evals now"; #xxx #xxx $esc = '[' . quotemeta($esc) . ']' if defined($esc) && ($esc ne ""); #xxx #xxx if (defined($esc) && ($esc ne "")) { #xxx eval "/$esc/"; #xxx $self->{'ERROR'} = $@ if $@; #xxx } #xxx #xxx $self->{'DBLESCAPE'} = $esc; #xxx #xxx if ($self->{'DEBUG'}) { #xxx print "DBLESC: $esc"; #xxx print ": ", $self->{'ERROR'} if $self->{'ERROR'}; #xxx print "\n"; #xxx } #xxx #xxx return $curesc; #xxx } #xxx #xxx sub case_sensitive { #xxx my $self = shift; #xxx my $setsense = shift; #xxx my $cursense = $self->{'CASESENSE'}; #xxx #xxx $self->{'CASESENSE'} = $setsense || !defined($setsense); #xxx #xxx print "CASE : ", $self->{'CASESENSE'}, "\n" #xxx if $self->{'DEBUG'}; #xxx #xxx return $cursense; #xxx } #xxx #xxx sub slow { #xxx my $self = shift; #xxx my $setslow = shift; #xxx my $curslow = $self->{'FORCESLOW'}; #xxx #xxx $self->{'FORCESLOW'} = $setslow || !defined($setslow); #xxx #xxx print "GOSLOW: ", $self->{'FORCESLOW'}, "\n" #xxx if $self->{'DEBUG'}; #xxx #xxx return $curslow; #xxx } #xxx #xxx sub keep { #xxx my $self = shift; #xxx my $setkeep = shift; #xxx my $curkeep = $self->{'KEEP'}; #xxx #xxx $self->{'KEEP'} = $setkeep || !defined($setkeep); #xxx #xxx print "KEEP : ", $self->{'KEEP'}, "\n" #xxx if $self->{'DEBUG'}; #xxx #xxx return $curkeep; #xxx } #xxx #xxx sub returndelim { #xxx my $self = shift; #xxx my $setrd = shift; #xxx my $currd = $self->{'RETURNDELIM'}; #xxx #xxx $self->{'RETURNDELIM'} = $setrd || !defined($setrd); #xxx #xxx print "RETURNDELIM : ", $self->{'RETURNDELIM'}, "\n" #xxx if $self->{'DEBUG'}; #xxx #xxx return $currd; #xxx } #xxx #xxx sub debug { #xxx my $self = shift; #xxx my $setdebug = shift; #xxx my $curdebug = $self->{'DEBUG'}; #xxx #xxx $self->{'DEBUG'} = $setdebug || !defined($setdebug); #xxx #xxx print "DEBUG : ", $self->{'DEBUG'}, "\n" #xxx if $self->{'DEBUG'}; #xxx #xxx return $curdebug; #xxx } #xxx #xxx sub error { #xxx my $self = shift; #xxx my $seterr = shift; #xxx my $curerr = $self->{'ERROR'}; #xxx #xxx $self->{'ERROR'} = $seterr if defined($seterr); #xxx return $curerr; #xxx } #xxx #xxx sub pre_matched { #xxx my $self = shift; #xxx $self->{'ERROR'} = "pre_matched requires keep" if !$self->{'KEEP'}; #xxx return $self->{'PRE'}; #xxx } #xxx #xxx sub matched { #xxx my $self = shift; #xxx $self->{'ERROR'} = "matched requires keep" if !$self->{'KEEP'}; #xxx return $self->{'MATCH'}; #xxx } #xxx #xxx sub post_matched { #xxx my $self = shift; #xxx $self->{'ERROR'} = "post_matched requires keep" if !$self->{'KEEP'}; #xxx return $self->{'POST'}; #xxx } #xxx #xxx sub dump { #xxx my $self = shift; #xxx my ($key, $val); #xxx #xxx print "Dump of DelimMatch:\n"; #xxx #xxx print "\n\tERROR : ", $self->{'ERROR'}, "\n" #xxx if $self->{'ERROR'}; #xxx #xxx print "\tStart : ", $self->{'STARTREGEXP'}, "\n"; #xxx print "\tEnd : ", $self->{'ENDREGEXP'}, "\n"; #xxx print "\tEscape: ", $self->{'ESCAPE'}, "\n"; #xxx print "\tDblEsc: ", $self->{'DBLESCAPE'}, "\n"; #xxx print "\tDebug : ", $self->{'DEBUG'}, "\n"; #xxx print "\tCase : ", $self->{'CASESENSE'}, "\n"; #xxx print "\tSlow : ", $self->{'FORCESLOW'}, "\n"; #xxx print "\tKeep : ", $self->{'KEEP'}, "\n"; #xxx print "\tQuote :\n"; #xxx while (($key, $val) = each %{$self->{'QUOTE'}}) { #xxx print "\t\t$key ... $val\n"; #xxx } #xxx print "\tBuffer: ", $self->{'BUFFER'}, "\n"; #xxx print "\tPrefix: ", $self->{'PRE'}, "\n"; #xxx print "\tMatch : ", $self->{'MATCH'}, "\n"; #xxx print "\tPost : ", $self->{'POST'}, "\n\n"; #xxx } #xxx #xxx sub match { #xxx my $self = shift; #xxx my $string = shift; #xxx my $state = 0; #xxx my $start = $self->{'STARTREGEXP'}; #xxx my $end = $self->{'ENDREGEXP'}; #xxx my %quote = %{$self->{'QUOTE'}}; #xxx my $escape = $self->{'ESCAPE'}; #xxx my $dblesc = $self->{'DBLESCAPE'}; #xxx my $debug = $self->{'DEBUG'}; #xxx my ($startq, $endq, $specialq) = ("", "", ""); #xxx my ($done) = 0; #xxx my ($depth) = 0; #xxx my (@states) = (); #xxx my ($accum) = ""; #xxx my ($regexp, $match, $pre, $matched, $post); #xxx my ($scratch); #xxx local $_ = "no -w warning in evals now"; #xxx #xxx return if $self->{'ERROR'}; #xxx #xxx if (defined($string)) { #xxx $self->{'BUFFER'} = $string; #xxx } else { #xxx # use post of previous match, if there was a match previously #xxx $self->{'BUFFER'} = $self->{'POST'} if $self->{'MATCH'} #xxx } #xxx #xxx $self->{'PRE'} = ""; #xxx $self->{'MATCH'} = ""; #xxx $self->{'POST'} = ""; #xxx #xxx if (!%quote && !$escape && !$dblesc && !$self->{'FORCESLOW'}) { #xxx print "FAST: $start, $end\n" if $debug; #xxx return $self->_fast0() if $start eq $end; #xxx return $self->_fast1(); #xxx } #xxx #xxx # build the regexp that matches the next important thing #xxx #xxx if (%quote) { #xxx $startq = join (")|(", keys %quote); #xxx $startq = "($startq)"; #xxx } #xxx #xxx if ($escape || $dblesc) { #xxx if ($escape && $dblesc) { #xxx $specialq = "($escape)|($dblesc)"; #xxx } elsif ($escape) { #xxx $specialq = "($escape)"; #xxx } else { #xxx $specialq = "($dblesc)"; #xxx } #xxx } #xxx #xxx $_ = $self->{'BUFFER'}; #xxx $self->{'BUFFER'} = ""; #xxx while ($state != 3) { #xxx if ($state == 0) { # before start tag #xxx $regexp = "($start)"; #xxx $regexp .= "|$startq" if $startq; #xxx $regexp .= "|($escape)" if $escape; #xxx } elsif ($state == 1) { # in start tag #xxx $regexp = "($start)|($end)"; #xxx $regexp .= "|$startq" if $startq; #xxx $regexp .= "|($escape)" if $escape; #xxx } elsif ($state == 2) { # in quote #xxx $regexp = $endq; #xxx $regexp .= "|$specialq" if $specialq; #xxx } else { #xxx $self->{'ERROR'} = "BAD STATE! THIS CAN'T HAPPEN!"; #xxx return; #xxx } #xxx #xxx print "STATE: $state: $regexp\n" if $debug; #xxx #xxx ($pre, $matched, $post) = $self->_match($regexp, $_); #xxx #xxx print "\tSTR : $_\n" if $debug; #xxx print "\tPRE : $pre\n" if $debug; #xxx print "\tMTCH: $matched\n" if $debug; #xxx print "\tPOST: $post\n" if $debug; #xxx #xxx last if !$matched; #xxx #xxx # First things first, if we've encountered an escaped #xxx # character, move along #xxx if ($escape && $self->_match ($escape, $matched)) { #xxx $accum .= $pre . $matched; #xxx $accum .= substr($post, 0, 1); #xxx $_ = substr ($post, 1); #xxx next; #xxx } #xxx #xxx if ($state == 0) { # looking for start or startq #xxx if ($self->_match($start, $matched)) { # matched start #xxx $state = 1; #xxx $depth++; #xxx print "START: $depth\n" if $debug; #xxx #xxx $self->{'PRE'} = $accum . $pre; #xxx $accum = $matched; #xxx $_ = $post; #xxx } else { # (must have) matched startq #xxx push (@states, $state); #xxx $state = 2; #xxx $accum .= $pre . $matched; #xxx foreach $scratch (keys %quote) { #xxx if ($self->_match ($scratch, $matched)) { #xxx $endq = $quote{$scratch}; #xxx last; #xxx } #xxx } #xxx $_ = $post; #xxx } #xxx } elsif ($state == 1) { #xxx if ($self->_match($end, $matched)) { # matched end #xxx $state = 1; #xxx $depth--; #xxx #xxx print "END : $depth\n" if $debug; #xxx $accum .= $pre . $matched; #xxx if ($depth == 0) { #xxx $state = 3; #xxx $self->{'MATCH'} = $accum; #xxx $self->{'POST'} = $post; #xxx $_ = ""; #xxx } else { #xxx $_ = $post; #xxx } #xxx } elsif ($self->_match($start, $matched)) { # matched start #xxx $state = 1; #xxx $depth++; #xxx print "START: $depth\n" if $debug; #xxx #xxx $accum .= $pre . $matched; #xxx $_ = $post; #xxx } else { # (must have) matched startq #xxx push (@states, $state); #xxx $state = 2; #xxx $accum .= $pre . $matched; #xxx foreach $scratch (keys %quote) { #xxx if ($self->_match ($scratch, $matched)) { #xxx $endq = $quote{$scratch}; #xxx last; #xxx } #xxx } #xxx $_ = $post; #xxx } #xxx } elsif ($state == 2) { #xxx # case 1, matched dblesc and is a doubled char #xxx if ($dblesc #xxx && $self->_match ($dblesc, $matched) #xxx && ($matched eq substr($post, 0, 1))) { # skip forward #xxx $accum .= $pre . $matched; #xxx $accum .= substr($post, 0, 1); #xxx $_ = substr($post, 1); #xxx next; #xxx } # otherwise check for other things then revisit #xxx #xxx if ($self->_match ($endq, $matched)) { # matched endq #xxx $state = pop (@states); #xxx $accum .= $pre . $matched; #xxx $_ = $post; #xxx } else { # (must have) matched a undoubled dblesc #xxx # usually this ends a quoted string #xxx # (and we'd never get here) #xxx # but since it didn't, just skip along #xxx $accum .= $pre . $matched; #xxx $_ = $post; #xxx } #xxx } else { #xxx $self->{'ERROR'} = "BAD STATE! THIS CAN'T HAPPEN!"; #xxx return; #xxx } #xxx } #xxx #xxx if ($state == 3) { #xxx $pre = $self->{'PRE'}; #xxx $match = $self->{'MATCH'}; #xxx $post = $self->{'POST'}; #xxx #xxx $match = $self->strip_delim($match) if !$self->{'RETURNDELIM'}; #xxx } else { #xxx $self->{'PRE'} = ""; #xxx $self->{'MATCH'} = ""; #xxx $self->{'POST'} = ""; #xxx undef $pre; #xxx undef $match; #xxx undef $post; #xxx } #xxx #xxx if (!$self->{'KEEP'}) { #xxx $self->{'PRE'} = ""; #xxx $self->{'MATCH'} = ""; #xxx $self->{'POST'} = ""; #xxx } #xxx #xxx return wantarray ? ($pre, $match, $post) : $match; #xxx } #xxx #xxx sub _fast0 { #xxx my $self = shift; #xxx my $delim = $self->{'STARTREGEXP'}; #xxx local $_ = $self->{'BUFFER'}; #xxx my ($pre, $match, $post); #xxx #xxx if ($self->{'CASESENSE'}) { #xxx $match = /^(.*?)($delim.*?$delim)(.*)$/s; #xxx ($pre, $match, $post) = ($1, $2, $3); #xxx } else { #xxx $match = /^(.*?)($delim.*?$delim)(.*)$/si; #xxx ($pre, $match, $post) = ($1, $2, $3); #xxx } #xxx #xxx if ($match) { #xxx $match = $self->strip_delim($match) if !$self->{'RETURNDELIM'}; #xxx #xxx if ($self->{'KEEP'}) { #xxx $self->{'PRE'} = $pre; #xxx $self->{'MATCH'} = $match; #xxx $self->{'POST'} = $post; #xxx } #xxx #xxx return wantarray ? ($pre, $match, $post) : $match; #xxx } else { #xxx return wantarray ? (undef, undef, undef) : undef; #xxx } #xxx } #xxx #xxx sub _fast1 { #xxx my $self = shift; #xxx my $string = $self->{'BUFFER'}; #xxx my $start = $self->{'STARTREGEXP'}; #xxx my $end = $self->{'ENDREGEXP'}; #xxx my $regexp = "($start)|($end)"; #xxx my $count = 0; #xxx my ($match, $realpre, $pre, $post, $matched); #xxx #xxx ($realpre, $match, $post) = $self->_match($start, $string); #xxx #xxx if (defined($match)) { #xxx $matched = $match; #xxx $string = $post; #xxx $count++; #xxx #xxx ($pre, $match, $post) = $self->_match($regexp, $string); #xxx #xxx while (defined($match)) { #xxx $matched .= $pre . $match; #xxx #xxx if ($self->_match($end, $match)) { #xxx $count--; #xxx } else { #xxx $count++; #xxx } #xxx #xxx $string = $post; #xxx last if $count == 0; #xxx #xxx ($pre, $match, $post) = $self->_match($regexp, $string); #xxx } #xxx #xxx if ($count == 0) { #xxx $matched = $self->strip_delim($matched) if !$self->{'RETURNDELIM'}; #xxx #xxx if ($self->{'KEEP'}) { #xxx $self->{'PRE'} = $realpre; #xxx $self->{'MATCH'} = $matched; #xxx $self->{'POST'} = $post; #xxx } #xxx #xxx return wantarray ? ($realpre, $matched, $post) : $matched; #xxx } #xxx } #xxx #xxx return wantarray ? (undef, undef, undef) : undef; #xxx } #xxx #xxx sub strip_delim { #xxx my $self = shift; #xxx my $string = shift; #xxx my $start = $self->{'STARTREGEXP'}; #xxx my $end = $self->{'ENDREGEXP'}; #xxx my $ok = 1; #xxx local $_ = "no -w warning in evals now"; #xxx #xxx return if $self->{'ERROR'}; #xxx #xxx $string = $self->{'MATCH'} if !defined($string); #xxx #xxx if ($string =~ /^$start/s) { #xxx my($rest) = $'; #xxx if ($rest =~ /^(.*)$end$/s) { #xxx return $1; #xxx } else { #xxx $self->{'ERROR'} = "FAILED TO MATCH END DELIMITER"; #xxx } #xxx } else { #xxx $self->{'ERROR'} = "FAILED TO MATCH START DELIMITER"; #xxx } #xxx #xxx return; #xxx } #xxx #xxx sub _match { #xxx my $self = shift; #xxx my $regexp = shift; #xxx local $_ = shift; #xxx my $match = 0; #xxx my ($pre, $matched, $post); #xxx #xxx if ($self->{'CASESENSE'}) { #xxx $match = /$regexp/s; #xxx ($pre, $matched, $post) = ($`, $&, $'); #xxx } else { #xxx $match = /$regexp/si; #xxx ($pre, $matched, $post) = ($`, $&, $'); #xxx } #xxx #xxx if ($match) { #xxx wantarray ? ($pre, $matched, $post) : $matched; #xxx } else { #xxx wantarray ? (undef, undef, undef) : undef; #xxx } #xxx } #xxx #xxx sub nested_match { #xxx my ($search, $start, $end, $three) = @_; #xxx my $mc = new DelimMatch $start, $end; #xxx my ($p, $m, $s) = $mc->match($search); #xxx #xxx if (defined($three)) { #xxx return wantarray ? ($p, $m, $s) : $m; #xxx } else { #xxx return wantarray ? ("$p$m", $s) : $m; #xxx } #xxx } #xxx #xxx sub skip_nested_match { #xxx my ($search, $start, $end, $three) = @_; #xxx my $mc = new DelimMatch $start, $end; #xxx my ($p, $m, $s) = $mc->match($search); #xxx #xxx if (defined($three)) { #xxx return wantarray ? ($p, $m, $s) : $s; #xxx } else { #xxx return wantarray ? ("$p$m", $s) : $s; #xxx } #xxx } #xxx #xxx 1; #xxx __END__ #xxx #xxx =head1 NAME #xxx #xxx Text::DelimMatch - Perl extension to find regexp delimited strings with proper nesting #xxx #xxx =head1 SYNOPSIS #xxx #xxx use Text::DelimMatch; #xxx #xxx $mc = new Text::DelimMatch, $startdelim, $enddelim; #xxx #xxx $mc->quote('"'); #xxx $mc->escape("\\"); #xxx $mc->double_escape('"'); #xxx $mc->case_sensitive(1); #xxx #xxx ($prefix, $match, $remainder) = $mc->match($string); #xxx ($prefix, $nextmatch, $remainder) = $mc->match(); #xxx #xxx $middle = $mc->strip_delim($match); # returns $match w/o start and end delim #xxx #xxx =head1 DESCRIPTION #xxx #xxx These routines allow you to match delimited substrings in a #xxx buffer. The delimiters can be specified with any regular #xxx expression and the start and end delimiters need not be the #xxx same. If the delimited text is properly nested, entire nested #xxx groups are returned. #xxx #xxx In addition, you may specify quoting and escaping characters that #xxx contribute to the recognition of start and end delimiters. #xxx #xxx For example, if you specify the start and end delimiters as '\(' and #xxx '\)', respectively, and the double quote character as a quoting character, #xxx and the backslash as an escaping character, then the delimited substring #xxx in this buffer is "(ma(t)c\)h)": #xxx #xxx 'prefix text "(quoted text)" \(escaped \" text) (ma(t)c\)h) postfix text' #xxx #xxx In order to support this rather complex interface, the matching context #xxx is encapsulated in an object. The object, Text::DelimMatch, #xxx has the following public methods: #xxx #xxx =over 4 #xxx #xxx =item new $start, $end, $escape, $dblesc, $qs1, $qe1, ... $qsn, $qen #xxx #xxx Creates a new object. All of the arguments are optional, and can be #xxx set with other methods, but they must be passed in the specified order: #xxx start delimiter, end delimiter, escape characters, double escape characters, #xxx and a set of quote characters. #xxx #xxx =item match $string #xxx #xxx In an array context, returns ($pre, $match, $post) where $pre is the #xxx text preceding the first match, $match is the matched text (including #xxx the delimiters), and $post is the rest of the text in the buffer. #xxx In a scalar context, returns $match. #xxx #xxx If $string is not provided on subsequent calls, the $post from the #xxx previous match is used, unless keep is false. If keep is false, the #xxx match always fails. #xxx #xxx =item strip_delim $string #xxx #xxx Returns $string with the start and end delimiters removed. #xxx #xxx =item delim $start, $end #xxx #xxx Set the start and end delimiters. Only one set of delimiters can be #xxx in use at any one time. #xxx #xxx Returns the delimters in use before this call. #xxx #xxx =item quote $startq, $endq #xxx #xxx Specifies the start and end quote characters. Multiple quote #xxx character pairs are supported, so this function is additive. To #xxx clear the current settings, pass no arguments, e.g., #xxx $mc->quote(). #xxx #xxx If only $start is passed, $end is assumed to be the same. #xxx #xxx In matching, quotes occur in pairs. In other words, if (",") #xxx and (',') are both specified as quote pairs and a string #xxx beginning with " is found, it is ended only by another ", not by '. #xxx #xxx Returns the quote hash in use before this call. #xxx #xxx =item escape $esc #xxx #xxx Specifies a set of escaping characters. This can only be a string #xxx of characters. $esc can be a regexp set or a simple string. If it #xxx is a simple string, it will be translated into the regexp set #xxx "[ quotemeta($esc) ]". #xxx #xxx Returns the escape characters in use before this call. #xxx #xxx =item double_escape $esc #xxx #xxx Specifies a set of double-escaping characters, i.e., characters that #xxx are considered escaped if they occur in pairs. For example, in some #xxx languages, #xxx #xxx 'Don''t you see?' #xxx #xxx defines a string containing a single apostrophe. #xxx #xxx $esc can only be a string of characters. $esc can be a regexp #xxx set or a simple string. If it is a simple string, it will be #xxx translated into the regexp set "[ quotemeta($esc) ]". #xxx #xxx Returns the double-escaping characters in use before this call. #xxx #xxx =item case_sensitive $bool #xxx #xxx Sets case sensitivity to $bool or true if $bool is not specified. #xxx #xxx Returns the case sensitivity in use before this call. #xxx #xxx =item keep $bool #xxx #xxx Sets keep to $bool or true if $bool is not specified. #xxx #xxx Keep, which is true by default, specifies whether or not the #xxx matching context object keeps a local copy of the buffer used in #xxx matching. Keeping a local copy allows repeated matching on the same #xxx buffer, but might be a bad idea if the buffer is a terabyte long. ;-) #xxx #xxx Returns the keep setting in use before this call. #xxx #xxx =item returndelim $bool #xxx #xxx Sets returndelim to $bool or true if $bool is not specified. #xxx #xxx Returndelim, which is true by default, specifies whether or not the #xxx start and end delimiters are returned with the matching string. #xxx #xxx Returns the returndelim setting in use before this call. #xxx #xxx =item error $seterr #xxx #xxx Returns the last error that occured. If $seterr is passed, the error is #xxx set to that value. Some common kinds of bad input are detected and an #xxx error condition is raised. If an error condition is raised, all matching #xxx fails until the error is cleared. #xxx #xxx The most common error is a bad regular expression, for example specifing #xxx the start delimiter as "(" instead of "\\(". Remember, these are regexps! #xxx #xxx =item pre_matched #xxx #xxx Returns the prefix text from the last match if keep is true. Sets #xxx an error and returns an empty string if keep is false. #xxx #xxx =item matched #xxx #xxx Returns the matched text from the last match if keep is true. Sets #xxx an error and returns an empty string if keep is false. #xxx #xxx =item post_matched #xxx #xxx Returns the postfix text from the last match if keep is true. Sets #xxx an error and returns an empty string if keep is false. #xxx #xxx =item debug $bool #xxx #xxx Sets debug to $bool or true if $bool is not specified. #xxx #xxx If debug is true, informative and progress messages are printed #xxx to STDOUT by some methods. #xxx #xxx Returns the debugging setting in use before this call. #xxx #xxx =item dump #xxx #xxx For debugging, prints all of the instance variables for a particular #xxx object. #xxx #xxx =item slow $bool #xxx #xxx For debugging. Some classes of delimited strings can be located #xxx with much faster algorithms than can be used in the most general #xxx case. If slow is true, the slower, general algorithm is always #xxx used. #xxx #xxx =back #xxx #xxx For simplicity, and backward compatibility with the previous #xxx (limited release) incarnation of this module, the following #xxx functions are also available directly: #xxx #xxx =over 4 #xxx #xxx =item nested_match ($string, $start, $end, $three) #xxx #xxx If $three is true, returns ($pre, $match, $post) in an array context #xxx otherwise returns ("$pre$match", $post). In a scalar context, returns #xxx "$pre$match". #xxx #xxx #xxx =item skip_nested_match ($string, $start, $end, $three) #xxx #xxx If $three is true, returns ($pre, $match, $post) in an array context #xxx otherwise returns ("$pre$match", $post). In a scalar context, returns #xxx $post. #xxx #xxx =back #xxx #xxx =head1 EXAMPLES #xxx #xxx $mc = new Text::DelimMatch '"'; #xxx $mc->('pre "match" post') == '"match"'; #xxx #xxx $mc->delim("\\(", "\\)"); #xxx $mc->('pre (match) post') == ('pre ', '(match)', ' post'); #xxx $mc->('pre (ma(t)ch) post') == ('pre ', '(ma(t)ch)', ' post'); #xxx #xxx $mc->quote('"'); #xxx $mc->escape("\\"); #xxx $mc->('pre (ma")"tch) post') == ('pre ', '(ma")"tch)', ' post'); #xxx $mc->('pre (ma(t)c\)h\") post') == ('pre ', '(ma(t)c\)h\")', ' post'); #xxx #xxx See also test.pl in the distribution. #xxx #xxx =head1 AUTHOR #xxx #xxx Norman Walsh, ndw@nwalsh.com #xxx #xxx =head1 COPYRIGHT #xxx #xxx Copyright (C) 1997-2002 Norman Walsh. #xxx All rights reserved. This program is free software; you can #xxx redistribute it and/or modify it under the same terms as Perl itself. #xxx #xxx =head1 WARRANTY #xxx #xxx THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR #xxx IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED #xxx WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR #xxx PURPOSE. #xxx #xxx =head1 SEE ALSO #xxx #xxx perl(1). #xxx #xxx =cut #xxx