vcproj04.pl to HTML.

index -|- end

Generated: Tue Feb 2 17:55:00 2010 from vcproj04.pl 2009/09/24 20.3 KB.

#!/perl -w
# NAME: vcproj04.pl
# AIM: To scan a VCPROJ file, and show the results
# 20090912 - add display of CWD, if can not find INPUT file name...
# This uses the services in fgscanvc.pl, to standardise the processing of a VCPROJ file
# so this is very different to vcproj03.pl, which had its own services to do the scan.
# 2009/09/22 - separarate into multiple 'temp' DSP outputs, using -NEW_PROJECT_NAME-
# but also avoid overwrtting previous out of same name...
# 2009-06-05 also try to attempt to output what the project will create... exe,lib,dll,...
# 05/12/2008 geoff mclane http://geoffair.net/mperl
use strict;
use warnings;
use Cwd;
use File::Basename;
unshift(@INC, 'C:/GTools/perl');
require 'fgutils.pl' or die "Unable to load fgutils.pl ...\n";
require 'fgdsphdrs02.pl' or die "Unable to load fgdsphdrs02.pl ...\n";
require 'fgscanvc02.pl' or die "Unable to load fgscanvc02.pl ...\n";
### require 'fgscanvc.pl' or die "Unable to load fgscanvc.pl ...\n";
# log file stuff
my $perl_base = "C:\\GTools\\perl"; # perl directory
my ($LF);
my $pgmname = $0;
if ($pgmname =~ /\w{1}:\\.*/) {
    my @tmpsp = split(/\\/,$pgmname);
    $pgmname = $tmpsp[-1];
}
my $outfile = $perl_base."\\temp.$pgmname.txt";
open_log($outfile);
# features
my $load_log = 1;   # load LOG file at end
my $write_dsp = 1;
my $out_dsp_dir = $perl_base;
my $dbg_val = 4+2;    # 1=split defines, 2=no show defines, etc, 4=show sources;
my $in_file = "C:\\Projects\\hb\\dirac\\win32\\VisualStudio\\dirac.sln";
#my $in_file = 'C:\Projects\hb\mp4v2\vstudio9.0\libmp4v2\libmp4v2.vcproj';
#my $in_file = 'C:\Projects\hb\libogg\win32\VS2008\libogg_static.sln';
#my $in_file = 'C:\Projects\hb\zlib\contrib\vstudio\vc8\zlibvc.sln';
#my $in_file = 'C:\Projects\hb\zlib\contrib\vstudio\vc7\zlibvc.vcproj';
#my $in_file = 'C:\Projects\freetype-2.3.9\builds\win32\vc2008\freetype.vcproj';
#my $in_file = 'C:\FG\27\TaxiDraw\msvc\7.1\TaxiDraw.vcproj';
#my $in_file = 'C:\FG\27\zlib-1.2.3\projects\visualc6\zlib.vcproj';
#my $in_file = 'C:\FG\27\FlightGear\projects\vc7.1\terrasync.vcproj';
#my $in_file = 'C:\FG\FGRUN\fgrunplib\fgrun.vcproj';
my @warnings = ();
#-- get current directory
my $pwd = cwd();
my @dsp_file_list = (); # simple list
my @project_list = ();  # [0]=name [1]=file
# debug 
my $dbg_sl01 = 0;
my $dbg_sl02 = 0;
my $dbg_sl03 = 0;
my $dbg01 = 0;  # show parse_arg in detail
my $curr_app_type = '';
# APP_TYPE
# $app_console_stg  = 'Console Application'  = get_dsp_head_console
# $app_windows_stg  = 'Application'          = get_dsp_head_app
# $app_dynalib_stg  = 'Dynamic-Link Library' = get_dsp_head_dynalib
# $app_statlib_stg  = 'Static Library'       = get_dsp_head_slib
my $help = <<EOF;
$pgmname [OPTIONS] in_file
OPTIONS:
 -? or -h        - This brief help.
 -dsp=dsp_dir    - Write DSP file to this directory. (def=$out_dsp_dir).
 -in=in_file     - Alternative to set input file.
 -type=TYPE      - Override project type. TYPES = [CA|WA|DLL|SL] only.
                   CA=Console App, WA=Windows App, DLL=Dynamic-Link, Lib SL=Static Library.
EOF
sub is_c_source_ext($) {
   my ($fil) = shift;
   my ($nm, $dir, $ext) = fileparse( $fil, qr/\.[^.]*/ );
   my $lce = lc($ext);
   if (($lce eq '.c') || ($lce eq '.cxx') || ($lce eq '.cpp') || ($lce eq '.cc')) {
      return 1;
   }
   return 0;
}
sub is_sln_ext($) {
   my ($fil) = shift;
   my ($nm, $dir, $ext) = fileparse( $fil, qr/\.[^.]*/ );
   my $lce = lc($ext);
   if ($lce eq '.sln') {
      return 1;
   }
   return 0;
}
sub is_vcproj_ext($) {
   my ($fil) = shift;
   my ($nm, $dir, $ext) = fileparse( $fil, qr/\.[^.]*/ );
   my $lce = lc($ext);
   if ($lce eq '.vcproj') {
      return 1;
   }
   return 0;
}
my $args_ref = parse_args(@ARGV);
# dbg_show_entering_files();
# dbg_show_source_files();
# dbg_show_output_files(); # { $dbg_v21 = 1; $dbg_v24 = 1; }
sub process_vcproj_file($$) {
    my ($in, $outd) = @_;
    my ($key,$tmp,$out,$cnt);
    prt( "$pgmname: Scanning [$in]...\n" );
    my %h = process_VCPROJ($in);
    if (length($curr_app_type)) {
        $key = 'APP_TYPE';
        if (defined $h{$key}) {
            $tmp = $h{$key};
            $h{$key} = $curr_app_type;
            if ($tmp ne $curr_app_type) {
                prt("Overrode $key with [$curr_app_type], from [$tmp]\n");
            }
        }
    }
    show_hash_results( $dbg_val, \%h );
    $key = '-NEW_PROJECT_NAME-';
    if ( $write_dsp && (defined $h{$key}) ) {
        $tmp = $h{$key};
        $outd .= "\\" if ( !($outd =~ /[\\\/]$/) );
        $out = $outd;
        $out .= "temp.".$tmp.".dsp";
        $cnt = 0;
        while ( is_in_array($out, @dsp_file_list) ) {
            $cnt++;
            $out = $outd;
            $out .= "temp.".$tmp.$cnt.".dsp";
        }
        if ( write_hash_to_DSP2( $out, \%h, 0 ) ) {
            push(@dsp_file_list,$out);
            push(@project_list, [ $tmp, $out ]);
        } else {
            prtw("WARNING: No DSP written for [$tmp] project.\n" );
        }
    } else {
        prtw("WARNING: NO PROJECT NAME! = NO DSP WRITTEN!\n");
    }
    return \%h;
}
# Read and store contents of SOLUTION (.sln) file
# 22/04/2008 - Extract DEPENDENCIES from solution file, and add to DSW output
sub process_SLN_file2($) {
   my ($fil) = shift;
   my ($cnt, $line, $vers, @arr, $mver, $par, $ff, $itmnum);
   my ($projname, $projfile, $projff, $gotproj, $relpath);
   my ($tnm,$tpth);
   my ($inproj, $tline, $projid, $inpdeps, $projdeps);
    my ($nmdeps, $depid, $pn);
    my ($msg);
   open IF, "<$fil" or mydie( "ERROR: Unable to open $fil ... $! ...\n" );
   my @lines = <IF>;
   close IF;
   $cnt = scalar @lines;
   my ($name,$sln_path) = fileparse($fil);
    my %hash = ();
    my %sln_projects = ();
    my %sln_projpath = ();
    my %sln_depends = ();
    my %sln_projids = ();
   prt( "\nProcessing $cnt lines ... n=[$name] p=[$sln_path] ...\n" );
   $projname = '';
   $projfile = '';
   $projff = '';
   $gotproj = 0;
   $inproj = 0;
   $inpdeps = 0;
   foreach $line (@lines) {
      $tline = trim_all($line);
      if ($line =~ /.+Format\s+Version\s+(\d+\.\d+)$/i) {
         $vers = $1;   # get n.nn version
         @arr = split(/\./,$vers);
         $mver = $arr[0];
         prt( "Is MSVC Version $mver ...\n" );
      } elsif ($line =~ /^Project\s*\(/) {
         # seek like 
         #Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "abyss", "abyss.vcproj", "{8B384B8A-2B72-4DC4-8DF1-E3EF32F18850}"
         ###prt( "Got project [$line] ...\n" );
         $inproj = 1;
         @arr = split( '=', $line );
         $cnt = scalar @arr;
         if ($cnt == 2) {
            $par = $arr[1];
            @arr = split(',', $par);
            $cnt = scalar @arr;
            if ($cnt == 3) {
               $projname = strip_quotes(trim_all($arr[0]));
               $projfile = strip_quotes(trim_all($arr[1]));
               $projid   = strip_quotes(trim_all($arr[2]));
               $projff = fix_rel_path($sln_path.$projfile);
               if ((length($projname)) && (is_vcproj_ext($projfile)) && (-f $projff)) {
                  $gotproj = 1;
                  ($tnm,$tpth) = fileparse($projff);
                  $relpath = get_rel_dos_path($tpth, $sln_path);
                  prt( "$pgmname: Got PROJECT name=$projname, file=$projff, rel=[$relpath].\n" ) if ($dbg_sl01);
                  if (defined $sln_projects{$projname}) {
                     mydie( "A PROBLEM: Already GOT this project name $projname!!!\n" );
                  } else {
                     $sln_projects{$projname} = $projff;
                     $sln_projpath{$projname} = $relpath; # can be BLANK, or say 'BvMath/'
                     $sln_projids{$projname}  = $projid;
                     $sln_depends{$projname}  = '';   # start dependencies, if any
                  }
               } else {
                  $msg = "WARNING: ";
                  if (!length($projname)) {
                     $msg .= "Failed to get a project name! ";
                  } elsif ( !is_vcproj_ext($projfile) ) {
                     $msg .= "Name [$projfile] NOT a VCPROJ name! ";
                  } else {
                     $msg .= "Unable to locate file [$projff]! ";
                  }
                  $msg .= " Line is (trimmed)\n$tline";
                        prtw("$msg\n");
               }
            } else {
               prtw( "Warning: Part 2 of Project line did NOT split into 3 on comma!???\n" );
            }
         } else {
            prtw( "Warning: Project line did NOT split in 2 on equal sign!???\n" );
         }
         # to switch on $tryharder requires additional work on parsing this line
         # =====================================================================
         prtw("WARNING: line [$line] ...\n") if (!$gotproj);
         # =====================================================================
      } elsif ($inproj) {
         # in the Project section - look for END of section, and DEPENDENCIES
         # ProjectSection(ProjectDependencies)
         if ($tline eq 'EndProject') {
         ###if ($line =~ /^EndProject\s*/)
            $inproj = 0;
         } else {
            if ($inpdeps) {
               if ($tline eq 'EndProjectSection' ) {
                  $inpdeps = 0;
               } else {
                  # collect dependencies
                  @arr = split( '=', $line );
                  $cnt = scalar @arr;
                  if ($cnt == 2) {
                     $arr[0] = trim_all($arr[0]);
                     $arr[1] = trim_all($arr[1]);
                     if ($arr[0] eq $arr[1]) {
                        $projdeps = $sln_depends{$projname};   # extract dependencies, if any
                        $projdeps .= '|' if (length($projdeps));
                        $projdeps .= $arr[0];
                        prt( "$pgmname: Proj $projname, dependant on $arr[0] ...\n" ) if ($dbg_sl02);
                        ##prt( "Proj $projname, dependant on $projdeps ...\n" );
                        $sln_depends{$projname} = $projdeps;
                     } else {
                        prtw( "Warning: Found different IDS '$arr[0]' NE '$arr[1]'!!! \n" );
                     }
                  } else {
                     prtw( "Warning: Project DEPENDENCY line did NOT split in 2 on equal sign!???\n" );
                     prtw( "line=$line" );
                  }
               }
            } elsif ($line =~ /ProjectSection\s*\(\s*ProjectDependencies\s*\)/) {
               $inpdeps = 1;
            }
         }
      }
   }
   ###prt( "Done $fil ... got ".scalar @proj_files." project files ...\n" );
   prt( "Done $fil ... got ".scalar keys(%sln_projects)." project files ...\n" );
   # resolve dependencies, if possible - warn if NOT ...
   #resolve_depends();
   foreach $projname (keys %sln_projects) {
      $projdeps = $sln_depends{$projname};
      if (length($projdeps)) {
         # there is LENGTH, convert giant CID to simple project names
         @arr = split( /\|/, $projdeps );   # split em up
         $cnt = scalar @arr;   # get count of split
         #prt( "Proj $projname, depends on $cnt = $projdeps ...\n" );
         $nmdeps = '';   # build simple NAME set
         foreach $depid (@arr) {
            foreach $pn (keys %sln_projids) {
               if ($pn ne $projname) {
                  $projid = $sln_projids{$pn};
                  if ($depid eq $projid) {
                     $nmdeps .= '|' if (length($nmdeps));
                     $nmdeps .= $pn;
                     last;
                  }
               }
            }
         }
         @arr = split( /\|/, $nmdeps );
         prt( "$pgmname: proj $projname, depends on $nmdeps ...\n" ) if ($dbg_sl03);
         if ($cnt != scalar @arr) {   # YEEK - Does NOT match - OH WELL
            prtw( "WARNING: Failed to get SAME count $cnt - got ".scalar @arr."!\n" );
         }
         $sln_depends{$projname} = $nmdeps;
      }
   }
    # ====================================================================
    $hash{'SOLUTION'} = $fil;   # keep the SOLUTION files also
    $hash{'PROJECTS'} = { %sln_projects };
    $hash{'PROJPATH'} = { %sln_projpath };
    $hash{'DEPENDS'} = { %sln_depends  };
    $hash{'PROJIDS'} = { %sln_projids };
    return \%hash;
}
sub remove_base_path($$) {
    my ($ln, $bs) = @_;
    my $len1 = length($ln);
    my $len2 = length($bs);
    if ($len1 < $len2) {
        return $ln;
    }
    my ($i,$c1,$c2);
    for ($i = 0; $i < $len2; $i++) {
        $c1 = lc(substr($ln,$i,1));
        $c2 = lc(substr($bs,$i,1));
        if ($c1 ne $c2) {
            return $ln;
        }
    }
    return substr($ln,$len2);
}
sub return_common_dir($$) {
    my ($d1,$d2) = @_;
    my ($ll,$k,$com);
    $com = '';
    $ll = length($d1);
    $ll = length($d2) if (length($d2) < $ll);   # get SHORTEST
    for ($k = 0; $k < $ll; $k++) {  # process for SHORTEST length
        last if (lc(substr($d1,$k,1)) ne lc(substr($d2,$k,1))); # end on first NOT SAME
        $com .= substr($d1,$k,1);   # else add to common
    }
    return $com;
}
sub get_common_dir($) {
    my ($rffh) = @_;
    my $commdir = '';
    my @keys = keys %{$rffh};
    my $kcnt = scalar @keys;
    my ($ky1,$ky2,$k,$com);
    for ($k = 0; ($k+1) < $kcnt; $k++) {
        $ky1 = $keys[$k];
        $ky2 = $keys[$k+1];
        $com = return_common_dir($ky1,$ky2);
        if (length($com) == 0) {
            return "";  # no COMMON
        }
        if (length($commdir)) {
            $com = return_common_dir($com,$commdir);
            if (length($com) == 0) {
                return "";  # no COMMON
            }
        }
        $commdir = $com;    # update the COMMON
    }
    return $commdir;
}
sub sln_file_processing($$$) {
   my ($flg,$in,$out) = @_;
   my ($k,$rsh,$val,$ff,$key,$captyp,$nm,$dir,$cnt,$i,$min1,$min2,$val2,$len);
   my ($refhash,$min);
   my @results = ();
   $rsh = process_SLN_file2($in);
   prt( "$pgmname: KEYS in SLN hash = " );
   foreach $k (keys %{$rsh}) {
      prt( "$k " );
   }
   prt("\n");
   # =====================================
   $k = 'PROJECTS';
   if (defined ${$rsh}{$k}) {
      # $sln_projects{$projname} = $projff;
      $val = ${$rsh}{$k};
      $min = 0;
      $cnt = 0;
      my %ffhash = ();
      foreach $k (keys %{$val}) {
          $ff = ${$val}{$k};
          $len = length($k);
          $min = $len if ($len > $min);
          if (is_vcproj_ext($ff)) {
              $ffhash{$ff} = 1;
              $cnt++;
          } else {
              $ffhash{$ff} = 0;
          }
      }
      my $commdir = get_common_dir( \%ffhash );
      prt( "All $cnt vcproj files in a COMMON PATH: [$commdir]\n" ) if (length($commdir));
      foreach $k (keys %{$val}) {
         $ff = ${$val}{$k};
         $ff = remove_base_path($ff,$commdir) if (length($commdir));
         $k .= ' ' while (length($k) < $min);
         prt("$k - $ff\n" );
      }
      prt( "\nNow to process EACH of the $cnt projects...\n" );
      # --------------------------------------------------
      foreach $k (keys %{$val}) {
          $ff = ${$val}{$k};
          # prt("$k - $ff\n" );
          ($nm, $dir) = fileparse($ff);
          if (is_vcproj_ext($ff)) {
              $refhash = process_vcproj_file($ff, $out);
              $key = 'APP_TYPE';
              if (defined ${$refhash}{$key}) {
                  $captyp = ${$refhash}{$key};
              } else {
                  $captyp = "Unknown - key=[$key] NOT SET"; 
              }
              push(@results, [$k, $nm, $captyp]);
          }
      }
   }
    $cnt = scalar @results;
    # get lengths, for neat output
    $min1 = 0;
    $min2 = 0;
    prt( "Solution file [$in], has $cnt projects...\n" );
    for ($i = 0; $i < $cnt; $i++) {
        $val = $results[$i][0];
        $val2 = $results[$i][1];
        $len = length($val);
        $min1 = $len if ($len > $min1);
        $len = length($val2);
        $min2 = $len if ($len > $min2);
    }
    for ($i = 0; $i < $cnt; $i++) {
        $val = $results[$i][0];
        $val2 = $results[$i][1];
        $val .= ' ' while (length($val) < $min1);
        $val2 .= ' ' while (length($val2) < $min2);
        prt("$val $val2 $results[$i][2]\n");
    }
    prt( "$pgmname: Done $cnt vcproj processing...\n" );
}
foreach $in_file (@{$args_ref}) {
   if (is_vcproj_ext($in_file)) {
      process_vcproj_file($in_file, $out_dsp_dir);
   } elsif (is_sln_ext($in_file)) {
      sln_file_processing(0, $in_file, $out_dsp_dir);
   } else {
      prtw( "WARNING: Unprocessed file extension! [$in_file]!\n" );
   }
}
if (@project_list) {
    write_proj_DSW( $out_dsp_dir."\\temp.$pgmname.DSW", \@project_list );
}
show_warnings();
close_log($outfile,$load_log);
# unlink($outfile);   # delete output file
exit(0);
##########################################################
sub prtw {
    my ($tx) = shift;
    $tx =~ s/\n$//;
    prt("$tx\n");
    push(@warnings,$tx);
}
sub show_warnings {
    if (@warnings) {
        prt( "\nGot ".scalar @warnings." WARNINGS ...\n" );
        foreach my $line (@warnings) {
            prt("$line\n" );
        }
        prt("\n");
    } else {
        prt("\nNo warnings issued.\n\n");
    }
}
sub give_help {
    prt( $help );
   mydie("In file must exist ...\n");
}
sub chk_arg {
    my ($arg, @av) = @_;
    fatal( "Invalid $arg - needs value ... -? for help ... aborting!\n" ) if !(@av);
}
sub need_arg {
   my ($a, @b) = @_;
   if (@b) {
      # ok
   } else {
      prt( "Error: $a argument requires additional item!\n" );
      give_help();
   }
}
sub parse_args { # @ARGV
    my (@av) = @_;
    my $dn = scalar @av;
    my @inp = ();
    my ($arg,$tmp,$i);
    if ($dbg01) {
        prt( "[dbg01] parsing $dn arguments... " );
        for ($i = 0; $i < $dn; $i++) {
            prt( "[".$av[$i]."]" );
        }
        prt("\n");
    }
    $dn = 0;
   while (@av) {
        $dn++;
      $arg = $av[0];
        prt( "[dbg01] $dn: $arg\n" ) if ($dbg01);
      if (substr($arg,0,1) eq '-') {
         if (($arg eq '-?')||($arg eq '-h')||($arg eq '--help')) {
            give_help();
            } elsif ($arg =~ /^-in=(.+)$/) {
             $in_file = $1;
                if (-f $in_file) {
                   prt( "Set in file to [$in_file] ...\n" );
                   push(@inp,$in_file);
                } else {
                    prt( "Current Work Directory = [$pwd]\n" );
                    mydie( "ERROR: Can NOT locate IN FILE [$in_file]! check name, location! aborting...\n" );
                }
            } elsif ($arg eq '-in') {
                need_arg($arg,@av);
                shift @av;
                $dn++;
                $arg = $av[0];
                prt("[dbg01] $dn: $arg\n") if ($dbg01);
             $in_file = $arg;
                if (-f $in_file) {
                   prt( "Set in file to [$in_file] ...\n" );
                   push(@inp,$in_file);
                } else {
                    prt( "Current Work Directory = [$pwd]\n" );
                    mydie( "ERROR: Can NOT locate IN FILE [$in_file]! check name, location! aborting...\n" );
                }
            } elsif ($arg eq '-dsp') {
                need_arg($arg,@av);
                shift @av;
                $dn++;
                $arg = $av[0];
                prt("[dbg01] $dn: $arg\n") if ($dbg01);
                prt( "Setting output file to [$arg], from [$out_dsp_dir]...\n" );
                $write_dsp = 1;
                $out_dsp_dir = $arg;
            } elsif ($arg =~ /$-dsp=(.+)$/) {
                $tmp = $1;
                prt( "Setting output file to [$tmp], from [$out_dsp_dir]...\n" );
                $out_dsp_dir = $tmp;
                $write_dsp = 1;
            } elsif ($arg =~ /^-type=(CA|WA|DLL|SL)$/) {
                $tmp = $1;
                if ( get_app_type_4_short($tmp,\$curr_app_type)  && length($curr_app_type) ) {
                 prt( "Set proj type override to [$curr_app_type] ($tmp)...\n" );
                } else {
                mydie( "ERROR: Unknown option [$arg] ... try -? ... aborting!\n" );
                }
            } elsif ($arg eq '-type') {
                need_arg($arg,@av);
                shift @av;
                $dn++;
                $arg = $av[0];
                prt("[dbg01] $dn: $arg\n") if ($dbg01);
                if ($arg =~ /^(CA|WA|DLL|SL)$/) {
                    $tmp = $1;
                    if ( get_app_type_4_short($tmp,\$curr_app_type) && length($curr_app_type) ) {
                        prt( "Set proj type override to [$curr_app_type] ($tmp)...\n" );
                    } else {
                        mydie( "ERROR: Unknown option [-type $arg] ... try -? ... aborting!\n" );
                    }
                } else {
                mydie( "ERROR: Unknown option [$arg]! Expected one {CA|WA|DLL|SL]!! try -? ... aborting!\n" );
                }
            } else {
            mydie( "ERROR: Unknown option [$arg] ... try -? ... aborting!\n" );
         }
      } else {
         # bare item - assume INPUT file
         $in_file = $arg;
         prt( "Set in file to $in_file ...\n" );
      }
      shift @av;
   }
    $dn = scalar @inp;
    if ($dn) {
        prt( "Got $dn file(s) to process...\n" );
    } else {
        if (-f $in_file) {
            prt( "Using default file [$in_file]...\n" );
            push(@inp,$in_file);
        } else {
            mydie( "ERROR: No file, or files to process...\n" );
        }
    }
    return \@inp;
}
# eof - vcproj04.pl

index -|- top

checked by tidy  Valid HTML 4.01 Transitional