create_base.pl

   1 #!/usr/bin/env 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.2';
  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     my $pline = undef;
  49
  50     while(<$fh>) {
  51       ## Get the line a remove leading and trailing white space
  52       my $line = $_;
  53       $line =~ s/^\s+//;
  54       $line =~ s/\s+$//;
  55
  56       ## Look for the project declaration and pull out the name and any
  57       ## parents.
  58       if ($line =~ /^project\s*(\(([^\)]+)\))?\s*(:.+)?\s*{$/) {
  59         $pname = $2;
  60         my $parents = $3 || '';
  61
  62         ## Create the default project name by removing the extension and
  63         ## converting back-slashes, spaces and dashes to underscores.
  64         ## This needs to be done regardless of whether the project name
  65         ## was provided or not since it's used below in the
  66         ## fill_type_name call.
  67         my $def = basename($name);
  68         $def =~ s/\.[^\.]+$//;
  69         $def =~ s/\\/_/g;
  70         $def =~ s/[\s\-]/_/g;
  71
  72         if (!defined $pname || $pname eq '') {
  73           ## Take the default project name since one wasn't provided.
  74           $pname = $def;
  75         }
  76         else {
  77           ## Convert back-slashes, spaces and dashes to underscores.
  78           $pname =~ s/\\/_/g;
  79           $pname =~ s/[\s\-]/_/g;
  80         }
  81
  82         ## If the project has a '*' we need to have MPC fix that up for
  83         ## us.
  84         $pname = Creator::fill_type_name(undef, $pname, $def);
  85         push(@lines, "project$parents {");
  86         $pline = $def;
  87       }
  88       elsif ($line =~ /^(shared|static)name\s*=\s*(.+)$/) {
  89         ## Add in the libs and after settings.
  90         my $lib = $2;
  91         if (defined $pname && $lib ne '') {
  92           push(@lines, "  libs  += $2",
  93                        "  after += $pname",
  94                        "}");
  95         }
  96         last;
  97       }
  98     }
  99     close($fh);
 100
 101     ## If we have the unmodified project name, but the user did not provide
 102     ## a sharedname or staticname, we will use that as the library name.
 103     if (defined $pline && $#lines == 0) {
 104       push(@lines, "  libs  += $pline",
 105                    "  after += $pname",
 106                    "}");
 107     }
 108
 109     ## Only return the lines if there is more than one line.
 110     return @lines if ($#lines > 0);
 111   }
 112
 113   return ();
 114 }
 115
 116 sub write_base {
 117   my($in, $out) = @_;
 118   my @lines = gather_info($in);
 119
 120   if ($#lines >= 0) {
 121     if (-r $out) {
 122       print STDERR "ERROR: $out already exists\n";
 123     }
 124     else {
 125       my $fh = new FileHandle();
 126       if (open($fh, ">$out")) {
 127         foreach my $line (@lines) {
 128           print $fh "$line\n";
 129         }
 130         close($fh);
 131
 132         ## Everything was ok, return zero.
 133         return 0;
 134       }
 135       else {
 136         print STDERR "ERROR: Unable to write to $out\n";
 137       }
 138     }
 139   }
 140   else {
 141     if (-r $in) {
 142       print STDERR "ERROR: $in is not a valid MPC file\n";
 143     }
 144     else {
 145       print STDERR "ERROR: Unable to read from $in\n";
 146     }
 147   }
 148
 149   ## Non-zero indicates an error (as in the shell $? value).
 150   return 1;
 151 }
 152
 153 sub usageAndExit {
 154   my $str = shift;
 155   print STDERR "$str\n" if (defined $str);
 156   print STDERR "Create Base Project v$version\n",
 157                "Usage: ", basename($0), " <mpc files> <output file or ",
 158                "directory>\n\nThis script will create a base project ",
 159                "based on the contents of the\nsupplied MPC file.\n";
 160   exit(0);
 161 }
 162
 163 # ******************************************************************
 164 # Main Section
 165 # ******************************************************************
 166
 167 if ($#ARGV > 1) {
 168   ## Get the last argument and make sure it's a directory.
 169   my $dir = pop(@ARGV);
 170   if (!-d $dir) {
 171     usageAndExit("Creating multiple base projects, but the " .
 172                  "last argument, $dir, is not a directory");
 173   }
 174
 175   ## Process each input file and create the base project with an implicit
 176   ## base project file name.
 177   my $status = 0;
 178   foreach my $input (@ARGV) {
 179     my $output = $dir . '/' . lc(basename($input));
 180     $output =~ s/mpc$/mpb/;
 181     $status += write_base($input, $output);
 182   }
 183   exit($status);
 184 }
 185 else {
 186   my $input  = shift;
 187   my $output = shift;
 188
 189   ## Print the usage and exit if there is no input, output or the input
 190   ## file looks like an option.
 191   usageAndExit() if (!defined $output ||
 192                      !defined $input  || index($input, '-') == 0);
 193
 194   ## If the output file is a directory, we will create the output file
 195   ## name based on the input file.
 196   if (-d $output) {
 197     $output .= '/' . lc(basename($input));
 198     $output =~ s/mpc$/mpb/;
 199   }
 200
 201   ## Create the base project and return the status to the caller of the
 202   ## script.
 203   exit(write_base($input, $output));
 204 }