vc_sln.pl to HTML.

index -|- end

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

index -|- top

checked by tidy  Valid HTML 4.01 Transitional