Generated: Mon Aug 16 14:14:44 2010 from vc_sln.pl 2010/05/16 13.5 KB.
#!/perl -w # NAME: vc_sln.pl # AIM: Scan a SLN file, and report contents use strict; use warnings; use File::Basename; # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[.]*/] ) use Cwd; unshift(@INC, 'C:\GTools\perl'); require 'logfile.pl' or die "Unable to load logfile.pl ...\n"; # log file stuff my ($LF); my $pgmname = $0; if ($pgmname =~ /\w{1}:\\.*/) { my @tmpsp = split(/\\/,$pgmname); $pgmname = $tmpsp[-1]; } my $perl_dir = 'C:\GTools\perl'; my $outfile = $perl_dir."\\temp.$pgmname.txt"; open_log($outfile); # user variables my $debug_on = 1; # run in EditPlus my $def_file = 'C:\Projects\fltk-1.1.10\vc2005\fltk.sln'; my $load_log = 1; my $in_file = ''; my $show_depends = 0; my $show_projects = 0; ### DEBUG my $dbg_sl_01 = 0; # prt( "Got PROJECT name=$projname, file=[$projfile], ff=[$projff], rel=[$relpath].\n" ) if ($dbg_sl_01); my $dbg_sl_02 = 0; # prt( "$pgmname: Proj $projname, dependant on $arr[0] ...\n" ) if ($dbg_sl_02); my $dbg_sl_03 = 0; # prt( "$pgmname: proj $projname, depends on $nmdeps ...\n" ) if ($dbg_sl_03); sub set_dbg_flags($) { my ($v) = shift; $dbg_sl_01 = $v; $dbg_sl_02 = $v; $dbg_sl_03 = $v; } sub set_dbg_on() { set_dbg_flags(1); } sub set_dbg_off() { set_dbg_flags(0); } ### program variables my @warnings = (); my $cwd = cwd(); my $os = $^O; my ($sln_file_nm,$sln_root_dir,$sln_file_ext); sub pgm_exit($$) { my ($val,$msg) = @_; if (length($msg)) { $msg .= "\n" if (!($msg =~ /\n$/)); prt($msg) } close_log($outfile,$load_log); exit($val); } 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 $itm (@warnings) { prt("$itm\n"); } prt("\n"); } else { prt( "\nNo warnings issued.\n\n" ); } } 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; } # Read and store contents of SOLUTION (.sln) file # 22/04/2008 - Extract DEPENDENCIES from solution file, and add to DSW output sub process_SLN_file3($) { my ($sln_fil_in) = 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,$text,$dspfile,$fdspfil); my $fil = $sln_fil_in; 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); # get the NAME, and SOLUTION PATH (should be ABSOLUTE, NOT relative) $sln_path = cwd() if ($sln_path =~ /^\.(\\|\/)$/); $sln_path .= "\\" if (!($sln_path =~ /(\\|\/)$/)); $sln_path =~ s/\//\\/g; # all to DOS 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]; # get 2nd part, like say '"abyss", "abyss.vcproj", "{8B384B8A-2B72-4DC4-8DF1-E3EF32F18850}"' @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_path3($sln_path.$projfile,'process_SLN_file3'); # return ABSOLUTE if ((length($projname)) && (is_vcproj_ext($projfile)) && (-f $projff)) { $gotproj = 1; ($tnm,$tpth,$text) = fileparse($projff,qr/\.[^.]*/); $fdspfil = $tpth.$tnm.".dsp"; $relpath = get_rel_dos_path($tpth, $sln_path); ($tnm,$tpth,$text) = fileparse($projfile,qr/\.[^.]*/); $dspfile = $tpth.$tnm.".dsp"; prt( "Got PROJECT name=$projname, file=[$projfile], ff=[$projff], rel=[$relpath].\n" ) if ($dbg_sl_01); 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/' # 0 1 2 3 4 $sln_projpath{$projname} = [$projfile,$projff,$relpath,$dspfile,$fdspfil]; # relative project file, like '..\alut\path\alut.vcproj' $sln_projids{$projname} = $projid; $sln_depends{$projname} = ''; # start dependencies, if any } ### pgm_exit(1,"TEMP EXIT"); } 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_sl_02); ##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_sl_03); 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; } } # ==================================================================== my %hash = (); $hash{'SOLUTION'} = $fil; # keep the SOLUTION files also $hash{'SLNPATH'} = $sln_path; # and its PATH $hash{'PROJECTS'} = { %sln_projects }; $hash{'PROJPATH'} = { %sln_projpath }; # array refs [$projfile,$projff,$relpath] $hash{'DEPENDS'} = { %sln_depends }; $hash{'PROJIDS'} = { %sln_projids }; # ===================================================================== return \%hash; } sub process_sln_file($) { my ($in) = @_; ($sln_file_nm,$sln_root_dir,$sln_file_ext) = fileparse($in, qr/\.[.]*/); my $rsh = process_SLN_file3($in); prt( "$pgmname: KEYS in SLN hash = " ); my ($k,$v,$k2,$v2,$min,$len,$dep,$tmp); my %hash = (); my (@arr,$cnt,@none); foreach $k (keys %{$rsh}) { prt( "$k " ); } prt("\n"); if ($show_depends) { $k = 'DEPENDS'; if (defined ${$rsh}{$k}) { $v = ${$rsh}{$k}; $min = 0; foreach $k2 (keys %{$v}) { $len = length($k2); $min = $len if ($len > $min); } @none = (); foreach $k2 (keys %{$v}) { $v2 = ${$v}{$k2}; $tmp = $k2; $tmp .= ' ' while (length($tmp) < $min); if (defined($v2) && length($v2) && !($v2 =~ /^\s$/)) { prt("$tmp -> [$v2]\n"); @arr = split(/\|/,$v2); foreach $dep (@arr) { if (defined $hash{$dep}) { $hash{$dep}++; } else { $hash{$dep} = 1; } } } else { prt("$tmp -> <none>\n"); push(@none,$k2); } } $cnt = scalar keys(%hash); prt("Total of $cnt dependents...\n"); foreach $k (keys %hash) { $v = $hash{$k}; prt("$k($v) "); } prt("\n") if ($cnt); } } if ($show_projects) { $k = 'PROJECTS'; if (defined ${$rsh}{$k}) { $v = ${$rsh}{$k}; $min = 0; $cnt = 0; foreach $k2 (keys %{$v}) { $len = length($k2); $min = $len if ($len > $min); prt("$k2 "); $cnt++; } if ($cnt) { prt("\nAbove is list of $cnt projects...\n"); } } } } ######################################### ### MAIN ### parse_args(@ARGV); #prt( "$pgmname: in [$cwd]: Hello, World...\n" ); process_sln_file($in_file); pgm_exit(0,"Normal exit(0)"); ######################################## sub give_help { prt("$pgmname: version 0.0.1 2010-05-05\n"); prt("Usage: $pgmname [options] input_sln_file\n"); prt("Options:\n"); prt(" -h (-?) = This help, and exit(0)\n"); prt(" -d = show depends.\n"); prt(" -p = show project list.\n"); prt(" -debug = Turn on ALL debug flags.\n"); prt("Purpose: Read input file as a solution file, and\n"); prt(" show its contents.\n"); } sub need_arg { my ($arg,@av) = @_; pgm_exit(1,"ERROR: [$arg] must have follwoing argument!\n") if (!@av); } sub parse_args { my (@av) = @_; while (@av) { my $arg = $av[0]; if ($arg =~ /-/) { my $sarg = substr($arg,1); $sarg = substr($sarg,1) while ($sarg =~ /-/); if (($sarg =~ /^h/i)||($sarg eq '?')) { give_help(); pgm_exit(0,"Help exit(0)"); } elsif ($sarg =~ /^d/i) { if ($sarg =~ /^degbug$/) { set_dbg_on(); prt("Set all debug on...\n"); } else { $show_depends = 1; prt("Set show depends.\n"); } } else { pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n"); } } else { $in_file = $arg; prt("Set input to [$in_file]\n"); } shift @av; } if (length($in_file)) { if (! -f $in_file) { pgm_exit(1,"ERROR: No input file given!"); } } else { if ($debug_on && length($def_file) && (-f $def_file)) { $in_file = $def_file; prt("Set input to DEFAULT [$in_file]\n"); #set_dbg_on(); $show_depends = 1; $show_projects = 1; } else { pgm_exit(1,"\nERROR: No input file given!\n\n"); } } } # eof - vc_sln.pl