create_base.pl

   1 #! /usr/bin/perl
   2 eval '(exit $?0)' && eval 'exec perl -w -S $0 ${1+"$@"}'
   3     & eval 'exec perl -w -S $0 $argv:q'
   4     if 0;
   5
   6 # ******************************************************************
   7 #      Author: Chad Elliott
   8 #        Date: 9/13/2007
   9 # Description: Generate a base project based on a library project
  10 # ******************************************************************
  11
  12 # ******************************************************************
  13 # Pragma Section
  14 # ******************************************************************
  15
  16 use strict;
  17 use FindBin;
  18 use FileHandle;
  19 use File::Spec;
  20 use File::Basename;
  21
  22 my $basePath = $FindBin::Bin;
  23 if ($^O eq 'VMS') {
  24   $basePath = File::Spec->rel2abs(dirname($0)) if ($basePath eq '');
  25     $basePath = VMS::Filespec::unixify($basePath);
  26 }
  27 unshift(@INC, $basePath . '/modules');
  28
  29 require Creator;
  30
  31 # ******************************************************************
  32 # Data Section
  33 # ******************************************************************
  34
  35 my $version = '0.1';
  36
  37 # ******************************************************************
  38 # Subroutine Section
  39 # ******************************************************************
  40
  41 sub gather_info {
  42   my $name = shift;
  43   my $fh = new FileHandle();
  44
  45   if (open($fh, $name)) {
  46     my @lines = ();
  47     my $pname = undef;
  48     while(<$fh>) {
  49       ## Get the line a remove leading and trailing white space
  50       my $line = $_;
  51       $line =~ s/^\s+//;
  52       $line =~ s/\s+$//;
  53
  54       ## Look for the project declaration and pull out the name and any
  55       ## parents.
  56       if ($line =~ /^project\s*(\(([^\)]+)\))?\s*(:.+)?\s*{$/) {
  57         $pname = $2;
  58         my $parents = $3 || '';
  59
  60         ## Create the default project name by removing the extension and
  61         ## converting back-slashes, spaces and dashes to underscores.
  62         ## This needs to be done regardless of whether the project name
  63         ## was provided or not since it's used below in the
  64         ## fill_type_name call.
  65         my $def = basename($name);
  66         $def =~ s/\.[^\.]+$//;
  67         $def =~ s/\\/_/g;
  68         $def =~ s/[\s\-]/_/g;
  69
  70         if (!defined $pname || $pname eq '') {
  71           ## Take the default project name since one wasn't provided.
  72           $pname = $def;
  73         }
  74         else {
  75           ## Convert back-slashes, spaces and dashes to underscores.
  76           $pname =~ s/\\/_/g;
  77           $pname =~ s/[\s\-]/_/g;
  78         }
  79
  80         ## If the project has a '*' we need to have MPC fix that up for
  81         ## us.
  82         $pname = Creator::fill_type_name(undef, $pname, $def);
  83         push(@lines, "project$parents {");
  84       }
  85       elsif ($line =~ /^(shared|static)name\s*=\s*(.+)$/) {
  86         ## Add in the libs and after settings.
  87         my $lib = $2;
  88         if (defined $pname && $lib ne '') {
  89           push(@lines, "  libs  += $2",
  90                        "  after += $pname",
  91                        "}");
  92         }
  93         last;
  94       }
  95     }
  96     close($fh);
  97
  98     ## Only return the lines if there is more than one line.  It is
  99     ## possible (and likely) that we've read in the project declaration,
 100     ## but the project did not contain a sharedname or staticname
 101     ## setting.
 102     return @lines if ($#lines > 0);
 103   }
 104
 105   return ();
 106 }
 107
 108 sub write_base {
 109   my($in, $out) = @_;
 110   my @lines = gather_info($in);
 111
 112   if ($#lines >= 0) {
 113     if (-r $out) {
 114       print STDERR "ERROR: $out already exists\n";
 115     }
 116     else {
 117       my $fh = new FileHandle();
 118       if (open($fh, ">$out")) {
 119         foreach my $line (@lines) {
 120           print $fh "$line\n";
 121         }
 122         close($fh);
 123
 124         ## Everything was ok, return zero.
 125         return 0;
 126       }
 127       else {
 128         print STDERR "ERROR: Unable to write to $out\n";
 129       }
 130     }
 131   }
 132   else {
 133     if (-r $in) {
 134       print STDERR "ERROR: $in is not a valid MPC file\n";
 135     }
 136     else {
 137       print STDERR "ERROR: Unable to read from $in\n";
 138     }
 139   }
 140
 141   ## Non-zero indicates an error (as in the shell $? value).
 142   return 1;
 143 }
 144
 145 sub usageAndExit {
 146   my $str = shift;
 147   print STDERR "$str\n" if (defined $str);
 148   print STDERR "Create Base Project v$version\n",
 149                "Usage: ", basename($0), " <mpc files> <output file or ",
 150                "directory>\n\nThis script will create a base project ",
 151                "based on the contents of the\nsupplied MPC file.  ",
 152                "This is only useful if the project ",
 153                "explictly sets\nsharedname or staticname.\n";
 154   exit(0);
 155 }
 156
 157 # ******************************************************************
 158 # Main Section
 159 # ******************************************************************
 160
 161 if ($#ARGV > 1) {
 162   ## Get the last argument and make sure it's a directory.
 163   my $dir = pop(@ARGV);
 164   if (!-d $dir) {
 165     usageAndExit("Creating multiple base projects, but the " .
 166                  "last argument, $dir, is not a directory");
 167   }
 168
 169   ## Process each input file and create the base project with an implicit
 170   ## base project file name.
 171   my $status = 0;
 172   foreach my $input (@ARGV) {
 173     my $output = $dir . '/' . lc(basename($input));
 174     $output =~ s/mpc$/mpb/;
 175     $status += write_base($input, $output);
 176   }
 177   exit($status);
 178 }
 179 else {
 180   my $input  = shift;
 181   my $output = shift;
 182
 183   ## Print the usage and exit if there is no input, output or the input
 184   ## file looks like an option.
 185   usageAndExit() if (!defined $output ||
 186                      !defined $input  || index($input, '-') == 0);
 187
 188   ## If the output file is a directory, we will create the output file
 189   ## name based on the input file.
 190   if (-d $output) {
 191     $output .= '/' . lc(basename($input));
 192     $output =~ s/mpc$/mpb/;
 193   }
 194
 195   ## Create the base project and return the status to the caller of the
 196   ## script.
 197   exit(write_base($input, $output));
 198 }