Generated: Mon Aug 16 14:14:42 2010 from vcdelcfg.pl 2010/05/28 23.3 KB.
#!/perl -w # NAME: vcdelcfg.pl # AIM: VERY SPECIFIC - Given a VCPROJ file, and a configuration name # delete that configuration. If just given the VCPROJ file, just list # existing configuration... # 28/05/2010 geoff mclane http://geoffair.net/mperl 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_mode = 1; my $debug_del = 1; my $debug_xml = 0; my $def_file = 'C:\Projects\fltk-1.3\ide\vc2005\arc.vcproj'; #my $def_file = 'C:\Projects\fltk-1.3\ide\vc2005\adjuster.vcproj'; #my $def_file = 'C:\Projects\fltk-1.3\ide\vc2005\ask.vcproj'; my $load_log = 1; my $in_file = ''; ### DEBUG my $dbg_01 = 0; # Configurations my $dbg_02 = 0; # Configuration my $dbg_03 = 0; # Files my $dbg_04 = 0; # File my $dbg_05 = 0; # FileConfiguration my $dbg_06 = 0; # show deleted line ### program variables my @warnings = (); my $cwd = cwd(); my $os = $^O; my @delcfgs = (); ### forward sub get_xml_hash($); 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 show_xml_hash($) { my ($rth) = @_; my ($key,$val,$min,$len); $min = 0; foreach $key (keys %{$rth}) { $val = ${$rth}{$key}; $len = length($key); $min = $len if ($len > $min); } foreach $key (keys %{$rth}) { $val = ${$rth}{$key}; $key .= ' ' while (length($key) < $min); prt(" $key = [$val]\n"); } } sub get_xml_hash($) { my ($x) = shift; my $len = length($x); my ($ch,$pc,$i,$tag,$val); $pc = ''; my %hash = (); $tag = ''; for ($i = 0; $i < $len; $i++) { $ch = substr($x,$i,1); last if ($ch eq '<'); } if ($ch eq '<') { $i++; for (; $i < $len; $i++) { $ch = substr($x,$i,1); last if (!($ch =~ /\w/)); $tag .= $ch; } if (length($tag)) { $hash{'* TAG *'} = $tag; return \%hash if ($ch eq '>'); while ($i < $len) { $tag = ''; $val = ''; # eat any spaces for (; $i < $len; $i++) { $ch = substr($x,$i,1); last if (!($ch =~ /\s/)); } # collect tag for (; $i < $len; $i++) { $ch = substr($x,$i,1); last if (($ch eq '/') || ($ch =~ /\s/) || ($ch eq '=') || ($ch eq '>')); $tag .= $ch; } if (($ch eq '/')||($ch eq '>')) { $hash{$tag} = $val if (length($tag)); if ($ch eq '/') { $hash{'* CLOSED *'} = 1; } return \%hash; } if ($ch eq '=') { # collect the value $i++; $pc = substr($x,$i,1); if ($pc eq '"') { $val = $pc; $i++; for (; $i < $len; $i++) { $ch = substr($x,$i,1); $val .= $ch; last if ($ch eq $pc); } $i++; # increment past final '"' char, already included } else { for (; $i < $len; $i++) { $ch = substr($x,$i,1); last if (($ch eq '/') || ($ch =~ /\s/) || ($ch eq '>')); $val .= $ch; } } $hash{$tag} = $val; } else { $hash{$tag} = $val if (length($tag)); } } } else { if ($ch eq '/') { # tag has no length # deal with a CLOSE $i++; for (; $i < $len; $i++) { $ch = substr($x,$i,1); last if (!($ch =~ /\w/)); $tag .= $ch; } if (length($tag)) { $hash{'* TAG *'} = $tag; $hash{'* ENDTAG *'} = 1; } } elsif (($ch eq '?') && ($x =~ /\?>$/) && ($len > 6)) { $i++; # header line <? blah blah ?> # [<?xml version="1.0" encoding="Windows-1252"?>] my $tmp = "<".substr($x,$i,($len - 4)).">"; my $rh = get_xml_hash($tmp); ${$rh}{'* HEADER *'} = 1; return $rh; } } } return \%hash; } sub get_xml_line_from_hash($) { my ($rh) = @_; my $xml = ''; my $key = '* TAG *'; my $hdr = ''; if ( ! defined ${$rh}{$key}) { prtw("WARNING: Reference hash does NOT have [$key] KEY!\nIt only contains -\n"); show_xml_hash($rh); return $xml; } $xml = '<'; # begin XML my $val = ${$rh}{$key}; # get the tag $key = '* ENDTAG *'; if (defined ${$rh}{$key}) { $xml .= "/$val"; my $cnt = 0; foreach $key (keys %{$rh}) { next if ($key =~ /^\*\s/); # skip these $cnt++; } $xml .= ">"; if ($cnt != 0) { prtw("WARNING: Somethings BAD about this ref hash...\n"); show_xml_hash($rh); } return $xml; } $key = '* HEADER *'; if (defined ${$rh}{$key}) { $hdr = '?'; $xml .= $hdr; } $xml .= "$val"; # add tag to XML foreach $key (keys %{$rh}) { next if ($key =~ /^\*\s/); # skip these $val = ${$rh}{$key}; # get value (already has quotes $xml .= " $key=$val"; # add to XML } $key = '* CLOSED *'; # check if a open/close tag if (defined ${$rh}{$key}) { $xml .= " /"; } $xml .= $hdr if (length($hdr)); $xml .= ">"; return $xml; } sub in_delete_list($) { my ($cfg) = shift; foreach my $tc (@delcfgs) { return 1 if ($cfg eq $tc); } return 0; } sub debug_xml_lines($) { my ($xml) = shift; my $rh = get_xml_hash($xml); my $x2 = get_xml_line_from_hash($rh); if ($debug_xml > 1) { prt("[$xml]\n"); prt("[$x2]\n"); } elsif ($xml ne $x2) { if ($debug_xml > 2) { prt("[$xml]\n"); prt("[$x2]\n"); } else { my $rh2 = get_xml_hash($x2); foreach my $key (keys %{$rh}) { my $v1 = ${$rh}{$key}; if (defined ${$rh2}{$key}) { my $v2 = ${$rh2}{$key}; if ($v1 ne $v2) { prt("Diff [$key] = [$v1] vs [$v2]\n"); } } else { prt("Key [$key] NOT in reconstitution..\n"); } } } } } sub get_bat_text($$$$) { my ($inf,$tmp,$nm,$dir) = @_; my $on = $nm.".old"; my $bn = $nm.".bak"; my $fon = $inf.".old"; my $fbn = $inf.".bak"; my $txt = <<EOF; \@echo Update? \@echo [$tmp] to \@echo [$inf] \@echo *** CONTINUE? *** \@pause \@if NOT EXIST $inf goto ERR1 \@if EXIST $fon goto DOBAK ren $inf $onn copy $tmp $inff \@goto END :DOBAK \@if NOT EXIST $fbn goto DOBAK2 del $fbnn :DOBAK2 ren $inf $bnn copy $tmp $inff \@goto END :ERR1 \@echo Error: Can NOT locate [$inf]! \@goto END :END EOF return $txt; } sub process_file($) { my ($inf) = shift; if (!open INF, "<$inf") { pgm_exit(1,"ERROR: Unable to open [$inf]!\n"); } my @lines = <INF>; close INF; my $lncnt = scalar @lines; prt("Processing $lncnt lines from [$inf]...\n"); my ($i,$line,$xml,$ch,$pc,$j,$len,$tline,$inele,$i2); my ($incfgs,$incfg,$rth,$key,$val); my ($infiles,$infile,$infcfg,$confcnt,$fconfcnt); my ($srccnt, $bgncfg, $endcfg, $actcfg,$msg,$indels,$deltot,$delcnt); my ($xlnn,$cntdels,$bgnxln,$endxln,$delxcnt,$delxtot); $ch = ''; $inele = 0; $incfgs = 0; $incfg = 0; $infiles = 0; $infile = 0; $infcfg = 0; $confcnt = 0; $fconfcnt = 0; $srccnt = 0; $actcfg = ''; $indels = 0; $deltot = 0; $cntdels = 0; $xlnn = 0; $delxtot = 0; my %configs = (); my %fileconf = (); my @sources = (); my @xmllines = (); my @configsfound = (); for ($i = 0; $i < $lncnt; $i++) { $i2 = $i + 1; $line = $lines[$i]; chomp $line; $tline = trim_all($line); $len = length($tline); for ($j = 0; $j < $len; $j++) { $pc = $ch; $ch = substr($tline,$j,1); $xml .= $ch; if ($inele) { if ($ch eq '>') { $inele = 0; debug_xml_lines($xml) if ($debug_xml); if ($incfgs) { # 486: </Configurations> if ($xml eq '</Configurations>') { $incfgs = 0; prt("$i2: End configs [$xml]\n") if ($dbg_01); } else { # 24: <Configuration Name="Debug|Win32" OutputDirectory=".\ask_" IntermediateDirectory=".\ask_" ConfigurationType="1" InheritedPropertySheets="$(VCInstallDir)VCProjectDefaults\UpgradeFromVC71.vsprops" UseOfMFC="0" ATLMinimizesCRunTimeLibraryUsage="false" > if ($incfg) { #if ($xml eq '</Configuration>') { # prt("$i2: End config [$xml]\n") if ($dbg_02); # $incfg = 0; # $endcfg = $i2; # prt( "Will DELETE lines $bgncfg to $endcfg\n" ) if ($indels); #} } else { if ($xml =~ /^<Configuration\s+/) { prt("$i2: Begin config [$xml]\n") if ($dbg_02); $bgncfg = $i2; $bgnxln = $xlnn; $incfg = 1; $rth = get_xml_hash($xml); $key = 'Name'; if (defined ${$rth}{$key}) { $val = strip_quotes(${$rth}{$key}); if (defined $configs{$val}) { prtw("WARNING: Config [$val] ALREADY DEFINED!\n"); } $configs{$val} = { %{$rth} }; $confcnt++; $actcfg = $val; $indels = in_delete_list($actcfg); $msg = ''; if ($indels) { push(@configsfound,$val); $msg = "FOR DELETE" } prt( "$i2:Config:$confcnt: [$val] $msg\n" ); } else { prtw("WARNING: 'Name' not defined in [$xml]!\n"); show_xml_hash($rth); } } } } } elsif ($infiles) { if ($xml eq '</Files>') { $infiles = 0; prt("$i2: End Files [$xml]\n") if ($dbg_03); } else { if ($infile) { if ($xml eq '</File>') { prt("$i2: End File [$xml]\n") if ($dbg_04); $infile = 0; } else { if ($infcfg) { # </FileConfiguration> #if ($xml eq '</FileConfiguration>') { # $infcfg = 0; # prt("$i2: End FileCFG [$xml]\n") if ($dbg_05); # $endcfg = $i2; # prt( "Will DELETE lines $bgncfg to $endcfg\n" ) if ($indels); #} } else { if ($xml =~ /^<FileConfiguration\s/) { prt("$i2: Begin FileCFG [$xml]\n") if ($dbg_05); $infcfg = 1; $bgncfg = $i2; $bgnxln = $xlnn; $rth = get_xml_hash($xml); $key = 'Name'; if (defined ${$rth}{$key}) { $val = strip_quotes(${$rth}{$key}); $fileconf{$val} = { %{$rth} }; $fconfcnt++; $actcfg = $val; $indels = in_delete_list($actcfg); $msg = ''; if ($indels) { push(@configsfound,$val); $msg = "FOR DELETE"; } prt( "$i2:FileCFG:$fconfcnt: [$val] $msg\n" ); } else { prtw("WARNING:$i2: 'Name' not defined in [$xml]!\n"); show_xml_hash($rth); } } } } } else { if ($xml =~ /^<File\s/) { prt("$i2: Begin File [$xml]\n") if ($dbg_04); $infile = 1; $rth = get_xml_hash($xml); $key = 'RelativePath'; if (defined ${$rth}{$key}) { $val = strip_quotes(${$rth}{$key}); $srccnt++; push(@sources,$val); prt( "$i2: Source $srccnt: [$val] ($indels)\n" ); } else { prtw("WARNING:$i2: 'RelativePath' not defined in [$xml]!\n"); show_xml_hash($rth); } } } } } else { # 15: <Configurations> if ($xml eq '<Configurations>') { $incfgs = 1; prt("$i2: Begin configs [$xml]\n") if ($dbg_01); } elsif ($xml eq '<Files>') { $infiles = 1; prt("$i2: Begin Files [$xml]\n") if ($dbg_03); } } #prt("$i2: $xml\n"); if ($indels) { prt("$i2: [$xml] DELETED\n") if ($dbg_06); $cntdels++; } else { push(@xmllines,$xml); } # POST processing if ($incfgs) { if ($incfg) { if ($xml eq '</Configuration>') { prt("$i2: End config [$xml]\n") if ($dbg_02); $incfg = 0; $endcfg = $i2; $endxln = $xlnn; if ($indels) { $delcnt = $endcfg - $bgncfg; $deltot += $delcnt; $delxcnt = $endxln - $bgnxln; $delxtot += $delxcnt + 1; prt( "$i2: Will DELETE file lines $bgncfg to $endcfg, $delcnt lines ($deltot), x-line $bgnxln - $endxln = $delxcnt ($delxtot)\n" ); $indels = 0; } } } } elsif ($infiles) { if ($infile) { if ($infcfg) { # </FileConfiguration> if ($xml eq '</FileConfiguration>') { $infcfg = 0; prt("$i2: End FileCFG [$xml]\n") if ($dbg_05); $endcfg = $i2; $endxln = $xlnn; if ($indels) { $delcnt = $endcfg - $bgncfg; $deltot += $delcnt; $delxcnt = $endxln - $bgnxln; $delxtot += $delxcnt + 1; prt( "$i2: Will DELETE file lines $bgncfg to $endcfg, $delcnt lines ($deltot), x-line $bgnxln - $endxln = $delxcnt ($delxtot)\n" ); $indels = 0; } } } } } } } elsif ($ch eq '<') { $inele = 1; $xml = $ch; $xlnn++; } } $xml .= ' ' if (!($xml =~ /\s$/)); } $inele = scalar @xmllines; prt( "Done file $lncnt lines, deleted $deltot, or\n"); $msg = "Check TOTALS!"; if (($delxtot == $cntdels)&&($delxtot == ($xlnn - $inele))) { $msg = "ok"; } prt( "Of $xlnn xml lines, and kept $inele, deleted $delxtot (".($xlnn - $inele)." or $cntdels) $msg\n"); if ($deltot == 0) { prt("Appears NOTHING to delete, so no update...\n"); # $configs{$val} = { %{$rth} }; # $fileconf{$val} = { %{$rth} }; } else { my ($name,$dir) = fileparse($inf); my $tmp = $perl_dir."\\temp.$name.xml"; $xml = join("\n",@xmllines); $xml .= "\n"; write2file($xml,$tmp); prt("Written to [$tmp] file...\n"); my $tmp2 = $perl_dir."\\temp.$name.bat"; $xml = get_bat_text($inf,$tmp,$name,$dir); write2file($xml,$tmp2); prt("Written to [$tmp2] file to do update...\n"); my $tmp3 = 'C:\MDOS'; if (-d $tmp3) { $tmp3 .= "\\tempupd.bat"; $xml = "call $tmp2\n"; write2file($xml,$tmp3); prt("Or run tempupd...\n"); } } if (@delcfgs) { my %h1 = (); my %h2 = (); foreach $key (@configsfound) { $h2{$key} = 0; } $inele = 0; foreach $key (@delcfgs) { $h1{$key} = 0; if ( ! defined $h2{$key}) { prtw("WARNING: Confiugration [$key] NOT FOUND\n"); $inele++; } } if ($inele) { prtw("WARNING: $inele CONFIGS NOT found...\n"); } else { prt("Appears all listed configs found...\n"); } } } ######################################### ### MAIN ### parse_args(@ARGV); prt( "$pgmname: in [$cwd]: Hello, World...\n" ); process_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 in_vcproj_file [configuration_to_delete]\n"); } sub need_arg { my ($arg,@av) = @_; pgm_exit(1,"ERROR: [$arg] must have follwoing argument!\n") if (!@av); } sub parse_args { my (@av) = @_; my $cnt = 0; 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)"); } else { pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n"); } } else { if ($cnt == 0) { $in_file = $arg; prt("Set input to [$in_file]\n"); } else { push(@delcfgs,$arg); prt("Added configuration [$arg] to delete.\n"); } $cnt++; } shift @av; } if (length($in_file) == 0) { if ($debug_mode) { if (-f $def_file) { $in_file = $def_file; prt("Set input to DEFAULT [$in_file]\n"); } } } if (length($in_file) == 0) { pgm_exit(1,"ERROR: No input file found!\n"); } if (@delcfgs) { prt("Got ".(scalar @delcfgs)." configs to delete...\n"); } elsif ($debug_mode && $debug_del) { prt("Adding [Debug Cairo|Win32] and [Release Cairo|Win32] to configs to delete...\n"); push(@delcfgs,"Debug Cairo|Win32"); push(@delcfgs,"Release Cairo|Win32"); } } # eof - vcdelcfg.pl