vcdelcfg.pl to HTML.

index -|- end

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

index -|- top

checked by tidy  Valid HTML 4.01 Transitional