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