#!/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
