@rem = '--*-Perl-*--
@echo off
perl -x -S "%0" %*
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
goto endofperl
@rem ';
#!perl -w
#line 11
use strict;
use integer;
use File::Copy;
use Text::Tabs;
use File::Path;
#use lib '/dev/tools/bin';
my @todo = ();
my $verbose = 0;
my $recurse = 0;
my $inVBHeader;
my $inAttributes;
my $isLastBlank;
my $ilevel;
my $lineno;
my $casecounter;
my $numlines = 0;
#-----------------------------
sub initFormat
{
$inVBHeader = 1;
$inAttributes = 0;
$isLastBlank = 0;
$ilevel = 0;
$lineno = 0;
$casecounter = 0;
}
#-----------------------------
sub termFormat
{
}
#-----------------------------
my $INDENT = ' ';
my $TYP_BLANKLINE = 1;
my $TYP_CODE = 2;
my $TYP_HEADEREND = 3;
my $TYP_HDRATTRIB = 4;
my $TYP_HEADER = 5;
my $TYP_METHODSTART = 6;
my $TYP_METHODEND = 7;
my $TYP_LOOPEND = 8;
my $TYP_LOOPSTART = 9;
my $TYP_INLINEIF = 10;
my $TYP_ELSE = 11;
my $TYP_SELECT = 12;
my $TYP_SELECTEND = 13;
my $TYP_CASE = 14;
my $TYP_LABEL = 15;
#-----------------------------
my %decOnTokens =
(
$TYP_METHODEND => 1,
$TYP_SELECTEND => 1,
$TYP_LOOPEND => 1,
$TYP_ELSE => 1,
);
#-----------------------------
my %incOnTokens =
(
$TYP_METHODSTART => 1,
$TYP_LOOPSTART => 1,
$TYP_ELSE => 1,
$TYP_SELECT => 1,
$TYP_CASE => 1,
) ;
#-----------------------------
sub formatLine($$)
{
my ($line, $rnewlines) = @_;
$lineno++;
$numlines++;
#format here...
my $linetype;
my $indent = '';
while (1)
{
$linetype = 0;
if ($inVBHeader or $inAttributes)
{
if ($line =~ /^END$/o)
{
$linetype = $TYP_HEADEREND;
}
elsif ($line =~ /^Attribute/o)
{
$linetype = $TYP_HDRATTRIB;
}
else
{
$linetype = $TYP_HEADER;
}
}
if ($linetype == 0)
{
$line =~ s/[ \t]+$//o; # remove trailing ws
$line =~ s/^\s+//o; # remove leading ws
$line = expand($line) if $line =~ /\t/; # remove tabs
if ($line =~ /^$/o)
{
$linetype = $TYP_BLANKLINE;
}
elsif ($line =~ /^if\s+.+\s+then\s+[^' ]/oi) #must be before normal 'if'
{
$linetype = $TYP_INLINEIF;
}
elsif ($line =~ /^(if|for|while|with)\s+/oi)
{
$linetype = $TYP_LOOPSTART;
}
elsif ($line =~ /^else\s*/oi)
{
$linetype = $TYP_ELSE ;
}
elsif ($line =~ /^end\s+(if|sub|with|type|enum|function|property)\s*/oi)
{
$linetype = $TYP_METHODEND;
}
elsif ($line =~ /^(private|public|friend)\s+(sub|type|enum|function|property)\s*/oi)
{
$linetype = $TYP_METHODSTART;
}
elsif ($line =~ /^(sub|type|function|property)[ \n]/oi)
{
$linetype = $TYP_METHODSTART;
}
elsif ($line =~ /^(next|wend|loop)[ \n]/oi)
{
$linetype = $TYP_LOOPEND;
}
elsif ($line =~ /^do\s+(while|until)\s+/oi)
{
$linetype = $TYP_LOOPSTART;
}
elsif ($line =~ /^select\s+/oi)
{
$linetype = $TYP_SELECT ;
delete ($decOnTokens{$TYP_CASE});
$casecounter = 0;
}
elsif ($line =~ /^end\s+select\s*/oi)
{
$linetype = $TYP_SELECTEND;
$ilevel-- if $casecounter > 0;
}
elsif ($line =~ /^case\s+/oi)
{
$casecounter++;
$linetype = $TYP_CASE;
$decOnTokens{$TYP_CASE} = 1 if $casecounter > 1;
}
elsif ($line =~ /^\w+\s*:/oi)
{
$linetype = $TYP_LABEL;
}
else
{
$linetype = $TYP_CODE;
}
}
if ($inVBHeader)
{
if ($linetype eq $TYP_HEADEREND or $linetype eq $TYP_HDRATTRIB)
{
$inVBHeader = 0;
$inAttributes = 1;
next if ($linetype eq $TYP_HDRATTRIB);
}
}
elsif ($inAttributes)
{
if ($linetype != $TYP_HDRATTRIB)
{
$inAttributes = 0;
next;
}
}
elsif ($linetype == $TYP_BLANKLINE)
{
return if ($isLastBlank);
$isLastBlank = 1;
}
else
{
$isLastBlank = 0;
$ilevel-- if exists($decOnTokens{$linetype});
warn "***ERROR: ilevel below zero: line($lineno) \n" if $ilevel < 0;
$indent = ($INDENT x $ilevel) if $linetype != $TYP_LABEL;
$ilevel++ if exists($incOnTokens{$linetype});
}
last;
}
$line = "\n" if ($line eq '');
#printf "%2d %s%s", $linetype, $indent, $line;
push @$rnewlines, "$indent$line";
}
#-----------------------------
sub forAllLines($$)
{
my ($rlines, $rnewlines) = @_;
initFormat();
foreach my $line (@$rlines)
{
#chomp $line;
formatLine($line, $rnewlines);
}
warn "***ERROR: ilevel != zero ($ilevel)\n" if $ilevel != 0;
#warn "***ERROR: still in header?" if ($inVBHeader or $inAttributes);
termFormat();
}
#-----------------------------
sub createBackup($$)
{
my ($f, $fbak) = @_;
unlink $fbak;
rename ($f, $fbak) or die "Can't create backup for $f: $!\n";
chmod 0644, $fbak;
}
#-----------------------------
sub slurpFile($$)
{
my ($f, $rlines) = @_;
open(FH, "< $f") or die "opening: $!";
@$rlines = <FH>;
close(FH) or die "closing: $!";
}
#-----------------------------
sub saveFormattedFile($$)
{
my ($f, $rnewlines) = @_;
open(FH, "> $f") or die "opening: $!";
print FH @$rnewlines;
close(FH) or die "closing: $!";
}
#-----------------------------
sub formatFile($)
{
my ($f) = @_;
my $fbak = "$f.bak";
createBackup($f, $fbak);
my @lines;
my @newlines;
slurpFile($fbak, \@lines);
forAllLines(\@lines, \@newlines);
saveFormattedFile($f, \@newlines);
}
#-----------------------------
sub formatAllFiles
{
foreach my $f (@_)
{
print "format file: $f\n";
formatFile($f);
}
}
#-----------------------------
sub processEntity($)
{
my ($t) = @_;
my @files = ();
if (-d $t)
{
my $dir = $t;
print "Processing Directory '$dir'\n" if $verbose;
opendir(DIR, $dir) or die "can't open directory $dir: $!\n";
my @all = readdir(DIR);
print "Directory '$dir' has ", scalar @all, " entries\n" if $verbose;
@files =
map {"$dir\\$_"}
grep {/\.(cls|bas|frm)$/}
@all;
if ($recurse)
{
my @dirs =
grep{-d $_ }
map {"$dir\\$_"}
grep {! /^\.\.?/}
@all;
push @todo, @dirs;
print "Directory '$dir' has ", scalar @dirs, " directories\n" if $verbose;
}
closedir(DIR);
print "Directory '$dir' has ", scalar @files, " VB files\n" if $verbose;
}
else
{
print "Processing file: '$t'\n" if $verbose;
-e $t or die "can't find file $t: $!\n";
push @files, $t;
}
formatAllFiles(@files);
}
#-----
## main
@todo = ();
my $t = ".";
foreach my $t(@ARGV)
{
if ($t eq '-v')
{
$verbose = 1;
}
elsif ($t eq '-r')
{
$recurse = 1;
}
else
{
push @todo, $t;
}
}
push @todo, '.' if (scalar @todo == 0);
#my ($buser, $bsystem, $x1, $x2) = times;
#foreach (1..10)
#{
foreach my $entity (@todo)
{
processEntity($entity);
}
#}
#my ($auser, $asystem, $x3, $x4) = times;
#no integer;
#print "User time : ", ($auser - $buser) , "\n";
#print "System time: ", ($asystem - $bsystem) , "\n";
print "Number of lines: ", $numlines, "\n" if $verbose;
__END__
:endofperl
|
@rem = '
@perl -S "%0" %*
@goto _perldone
@rem ';
#!perl -w
use CWD;
use strict;
my $inc = ' ';
#$ARGV[0] = "d:\\projects\\build\\testpretty.txt";
##---------------------------------------------------
sub usage
{
print "usage: $0 filename\n";
exit(0);
}
usage unless defined $ARGV[0];
my $f = $ARGV[0];
die "file $f not found\n" if (!-e $f);
rename $f, "$f.orig";
open FH, "<$f.orig" or die "Can't open file: $!\n";
open OUT, ">$f" or die "Can't open file: $!\n";
my $indent = 0;
my $dec = 0;
my $nextinc = 0;
my $lastblank = 0;
my $extra = 0;
my $openparens = 0;
my $openparensposn = 0;
my $closeparens = 0;
my $cparens = 0;
my $prevcparens = 0;
my %leadwords;
my $comment;
my $inlinecomment = 0;
my $prefix;
my $inlineprefix = 0;
#my $prevcase = 0;
my @lines;
my @lines1;
@lines1 = <FH>;
close FH;
foreach(@lines1)
{
if (/^(\s*if\s*\(.*\)\s*){\s*(.*)$/)
{
push @lines, $1;
push @lines, '{';
my $x = $2;
push (@lines, $x) unless $x =~ /^\s*$/;
next;
}
if (/^\s*}\s*else\s*{\s*(.*)$/)
{
push @lines, '}';
push @lines, 'else';
push @lines, '{';
my $x = $1;
push (@lines, $x) unless $x =~ /^\s*$/;
next;
}
if (/^\s*}\s*(elsif\s*\(.*\))\s*{\s*(.*)$/)
{
push @lines, '}';
push @lines, $1;
push @lines, '{';
my $x = $2;
push (@lines, $x) unless $x =~ /^\s*$/;
next;
}
if (/^\s*}\s*elsif\s*(.*)$/)
{
push @lines, '}';
push @lines, "elsif $1";
next;
}
if (/^\s*foreach\s*(\S+)?\((.*)\)\s*{\s*(.*)$/)
{
push @lines, "foreach $1 ($2)";
push @lines, '{';
my $x = $3;
push (@lines, $x) unless $x =~ /^\s*$/;
next;
}
if (/^\s*sub\s*(.*)\s*{\s*(.*)$/)
{
push @lines, "sub $1";
push @lines, '{';
my $x = $2;
push (@lines, $x) unless $x =~ /^\s*$/;
next;
}
push @lines, $_;
}
foreach (@lines)
{
$inlinecomment = 0;
$inlineprefix = 0;
### remove leading whitespace
s/^\s+//;
### remove trailing whitespace
s/\s+$//;
### convert tabs to spaces: assume 8 char tab stops
1 while s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
/^([#a-zA-Z_1-9]+)(.*)$/;
if ($1 eq 'RSIM' or $1 eq 'GDBG')
{
$prefix = $1;
#print "len=" . length($prefix) . "\n";
$inlineprefix = 1;
$_ = $2;
s/^\s+//; ### remove leading whitespace
}
### adjust some spacing:
s/^if\s*\(/if (/;
s/^for\s*\(/for (/;
s/^switch\s*\(/switch (/;
s/^while\s*\(/while (/;
s/^return\s*\(/return (/;
s/^case\s+/case /;
s/^return\s+/return /;
s/^TASSERT\s+\(/TASSERT(/;
s/^using\s+/using /;
# /^(\S+)/;
# $leadwords{$1}++ if $1;
### get rid of multiple blank lines
if (/^$/)
{
next if $lastblank;
$lastblank = 1;
}
else
{
$lastblank = 0;
}
###indent if there is an unmatched open parens
$openparens = ( s/\(/\(/g ) || 0;
$openparensposn = index $_, "(";
$closeparens = ( s/\)/\)/g ) || 0;
$prevcparens = $cparens;
$cparens += $openparens - $closeparens;
### if we saw an if,else,for,etc last line
### and the current line is not a brace
### increment the current line, but only the current line
if ($nextinc && (! /^{$/ && $cparens == 0))
{
$indent += $nextinc;
$dec--;
}
$nextinc = 0;
$indent++ if ( /^{$/ ); ## bump increment on opening brace
if ( /^}$/)
{
$dec--; ## decrement on closing brace
$cparens = 0;
}
### restore indentation
s/^/$inc x $indent . ' ' x $extra/e;
if ($inlineprefix)
{
my $len = length($prefix);
s/^ {1,$len}//;
$_ = $prefix . ' ' . $_;
}
if ($inlinecomment)
{
my $len = 55 - length;
while ($len < 0)
{
$len += 20;
}
$_ .= ' ' x $len . $comment;
}
###indent if there is an unmatched open parens
if ($prevcparens == 0 && $cparens != 0)
{
$extra = $openparensposn + 1;
}
elsif ($cparens == 0)
{
$extra = 0;
}
# s/$/" \/\/cbkt:$cparens obkt=$openparens clbkt=$closeparens"/e if ($cparens);
$indent += $dec;
$dec = 0;
SPEW: print OUT "$_\n";
}
close OUT;
print "Done!\n";
#foreach(sort keys %leadwords)
# {
# print "$_: $leadwords{$_}\n";
# }
__END__
####
if (0)
{
#/^([^ ;([\-*]+)/;
/^([#a-zA-Z_1-9]+)/;
$leadwords{$1}++
unless
## control keywords
$1 eq 'break' ||
$1 eq 'default' ||
$1 eq 'continue' ||
$1 eq 'case' ||
$1 eq 'else' ||
$1 eq 'for' ||
$1 eq 'if' ||
$1 eq 'return' ||
$1 eq 'switch' ||
$1 eq 'while' ||
$1 eq 'using' ||
$1 eq 'delete' ||
$1 eq 'goto' ||
$1 eq 'catch' ||
$1 eq 'try' ||
$1 eq 'throw' ||
## decl
$1 eq 'int' ||
$1 eq 'char' ||
$1 eq 'long' ||
$1 eq 'short' ||
$1 eq 'unsigned' ||
$1 eq 'bool' ||
$1 eq 'double' ||
$1 eq 'const' ||
$1 eq 'struct' ||
$1 eq 'public' ||
$1 eq 'private' ||
$1 eq 'class' ||
$1 eq 'extern' ||
$1 eq 'static' ||
$1 eq 'void' ||
##MS & Windows decl
$1 eq 'RECT' ||
$1 eq 'HWND' ||
$1 eq 'HWND_TOP' ||
$1 eq 'HFONT' ||
$1 eq 'BOOL' ||
$1 eq 'LONG' ||
$1 eq 'LPDISPATCH' ||
$1 eq 'HRESULT' ||
$1 eq 'TRUE' ||
$1 eq 'FALSE' ||
$1 eq 'SHORT' ||
$1 eq 'SUCCEEDED' ||
$1 eq 'NULL' ||
$1 eq 'DWORD' ||
$1 eq 'BSTR' ||
$1 eq 'SAFEARRAY' ||
$1 eq 'SAFEARRAYBOUND' ||
$1 eq 'BYTE' ||
$1 eq 'DATE' ||
$1 eq 'TCHAR' ||
$1 eq 'VARIANT' ||
$1 eq 'VARIANT_BOOL' ||
$1 eq 'CURRENCY' ||
$1 eq 'HINSTANCE' ||
$1 eq 'MSG' ||
$1 eq 'LPCTSTR' ||
$1 eq '_variant_t' ||
$1 eq '_bstr_t' ||
$1 eq 'IDispatch' ||
## preproc
$1 eq '#define' ||
$1 eq '#ifdef' ||
$1 eq '#if' ||
$1 eq '#else' ||
$1 eq '#include' ||
$1 eq '#endif' ||
$1 eq '#pragma' ||
$1 eq '#import' ||
##api calls
$1 eq 'memset' ||
$1 eq 'memcpy' ||
$1 eq 'strcpy' ||
$1 eq 'sprintf' ||
$1 eq 'va_start' ||
$1 eq 'va_end' ||
$1 eq 'va_list' ||
$1 eq 'free' ||
$1 eq '_tcscpy' ||
$1 eq '_stprintf' ||
##MS & windows api
$1 eq '_ASSERT' ||
$1 eq '_ASSERTE' ||
$1 eq '_RPT' ||
$1 eq '_RPT0' ||
$1 eq '_CrtDumpMemoryLeaks' ||
$1 eq '_CrtSetDbgFlag' ||
$1 eq 'WinMain' ||
$1 eq 'DestroyWindow' ||
$1 eq 'GetClientRect' ||
$1 eq 'SysFreeString' ||
$1 eq 'ListBox_AddString' ||
$1 eq 'ListBox_DeleteString' ||
$1 eq 'ListBox_SetTopIndex' ||
$1 eq 'MAKEINTRESOURCE' ||
$1 eq '_COM_SMARTPTR_TYPEDEF' ||
$1 eq 'STDMETHODIMP' ||
$1 eq '_Module' ||
$1 eq 'OBJECT_ENTRY' ||
$1 eq 'REGCLS_MULTIPLEUSE' ||
$1 eq 'CoUninitialize' ||
$1 eq 'BEGIN_OBJECT_MAP' ||
$1 eq 'END_OBJECT_MAP' ||
$1 eq 'PostThreadMessage' ||
$1 eq 'SetWindowFont' ||
$1 eq 'SetWindowLong' ||
$1 eq 'SetWindowPos' ||
$1 eq 'ShowWindow' ||
$1 eq 'Static_SetText' ||
$1 eq 'Beep' ||
$1 eq 'CloseHandle' ||
$1 eq 'ReleaseMutex' ||
$1 eq 'Sleep' ||
$1 eq 'WaitForSingleObject' ||
$1 eq 'VariantClear' ||
$1 eq 'VariantInit' ||
$1 eq 'CComQIPtr' ||
##punctuation
$1 eq '{' ||
$1 eq '}' ||
$1 eq '};' ||
$1 eq '/*' ||
$1 eq '' ||
$1 =~ /^\/\// ||
##Common Gilbarco
$1 =~ /^m_/ || # member variable
$1 =~ /^GCmd_/ || # command
$1 =~ /^GEvt_/ || # command
$1 eq 'CMLCreate' ||
$1 eq 'CMLRegisterCtor' ||
$1 eq 'CMLRegisterDtor' ||
$1 eq 'CMLRegisterInit' ||
$1 eq 'CMLRegisterTerm' ||
$1 eq 'rc' ||
$1 eq 'hr' ||
$1 eq 'vData' ||
$1 eq 'TASSERT' ||
$1 eq 'TASSERTI' ||
$1 eq 'GTracerInit' ||
$1 eq 'GTracerTerm' ||
$1 eq 'TError' ||
$1 eq 'TErrorHR' ||
$1 eq 'TInfo' ||
$1 eq 'TInfoHR' ||
$1 eq 'TInfoEntry' ||
$1 eq 'TEntry' ||
$1 eq 'TLog' ||
$1 eq 'GDBG' ||
$1 eq 'RSIM' ||
$1 eq 'ASSERT_VALID_DELETE' ||
$1 eq 'RAISE_ERROR' ||
$1 eq 'ASSERT_VALID_RELEASE' ||
$1 eq 'ASSERT_VALID_ARRAY_DELETE' ||
$1 eq 'GTRACE'
;
}
####
#:_perldone
|
@rem = '--*-Perl-*--
@echo off
perl -x -S "%0" %*
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
goto endofperl
@rem ';
#!perl -w
#line 11
use strict;
use integer;
use File::Find;
my $VB_ALL = 2;
my $VB_MED = 1;
my $VB_LOW = 0;
my $VB_NONE = -1;
my $verbose = $VB_NONE;
my %vbpfiles;
# two outputs:
# depends : a list in sorted dependency order
# cyclebuster: a list of files
my @depends;
my @cyclebusters;
#------------------------------------------
sub dumpVbpFiles()
{
print "\n\n-------------------\n";
print "---- Component information from .vbp files\n";
foreach my $srccomp (sort keys %vbpfiles)
{
print "component: $vbpfiles{$srccomp}{compname}:\n";
print " fqpath : $vbpfiles{$srccomp}{fqpath}\n";
print " numoutrefs: $vbpfiles{$srccomp}{numoutrefs}\n";
print " numfilled : $vbpfiles{$srccomp}{numfilled}\n";
print " numinrefs : $vbpfiles{$srccomp}{numinrefs}\n";
my $rrefs = $vbpfiles{$srccomp}{vbrefs};
foreach my $comp (sort keys %{$rrefs})
{
print " component=$comp\n";
print " clsid =$vbpfiles{$srccomp}{vbrefs}{$comp}{clsid}\n";
print " fulfilled=$vbpfiles{$srccomp}{vbrefs}{$comp}{fulfilled}\n";
}
print "\n";
}
print "--------end of vbpfile information list\n";
}
#------------------------------------------
sub dumpSummaryDependencyList()
{
print "\n\n-------------------\n";
print "---- Dependency List\n";
my $order = 0;
foreach my $srccomp (@depends)
{
$order++;
print "component[$order]: $srccomp->{compname}\n";
}
print "--------end of depends list\n";
}
#------------------------------------------
sub dumpSummaryCycleBustersList()
{
print "\n\n-------------------\n";
print "---- CycleBusters List\n";
my $order = 0;
foreach my $srccomp (@cyclebusters)
{
$order++;
print "component[$order]: $srccomp->{compname}\n";
}
print "--------end of cyclebusters list\n";
}
#------------------------------------------
sub dumpDependencyList()
{
print "\n\n-------------------\n";
print "---- Dependency List\n";
my $order = 0;
foreach my $srccomp (@depends)
{
$order++;
print "component[$order]: $srccomp->{compname}:\n";
print " fqpath : $srccomp->{fqpath}\n";
print " numoutrefs: $srccomp->{numoutrefs}\n";
print " numinrefs : $srccomp->{numinrefs}\n";
# print " numfilled : $vbpfiles{$srccomp}{numfilled}\n";
# my $rrefs = $vbpfiles{$srccomp}{vbrefs};
# foreach my $comp (sort keys %{$rrefs})
# {
# print " component=$comp\n";
# print " clsid =$vbpfiles{$srccomp}{vbrefs}{$comp}{clsid}\n";
# print " fulfilled=$vbpfiles{$srccomp}{vbrefs}{$comp}{fulfilled}\n";
# }
print "\n";
}
print "--------end of depends list\n";
}
#------------------------------------------
sub dumpCycleBusters()
{
print "\n\n-------------------\n";
print "---- CycleBusters List\n";
my $order = 0;
foreach my $srccomp (@cyclebusters)
{
$order++;
print "component[$order]: $srccomp->{compname}:\n";
print " fqpath : $srccomp->{fqpath}\n";
print " numoutrefs: $srccomp->{numoutrefs}\n";
print " numinrefs : $srccomp->{numinrefs}\n";
# print " numfilled : $vbpfiles{$srccomp}{numfilled}\n";
# my $rrefs = $vbpfiles{$srccomp}{vbrefs};
# foreach my $comp (sort keys %{$rrefs})
# {
# print " component=$comp\n";
# print " clsid =$vbpfiles{$srccomp}{vbrefs}{$comp}{clsid}\n";
# print " fulfilled=$vbpfiles{$srccomp}{vbrefs}{$comp}{fulfilled}\n";
# }
print "\n";
}
print "--------end of cyclebusters list\n";
}
#------------------------------------------
sub dumpAntLists
{
print "\n\n-------------------\n";
print "---- ANT List\n";
foreach my $srccomp (@depends)
{
print " $srccomp->{compname},\n";
}
print "\n";
foreach my $srccomp (sort {$a->{compname} cmp $b->{compname}} @cyclebusters)
{
print " $srccomp->{compname},\n";
}
print "\n\n----Cyclebusters part1 --------------\n";
foreach my $srccomp (sort {$a->{compname} cmp $b->{compname}} @cyclebusters)
{
print " <copy file=\"\${VB_ROOT}\\compat\\$srccomp->{compname}.dll\" todir=\"\${BUILD_ROOT}\"/>\n";
}
print "\n";
print " <apply executable=\"regsvr32.exe\" >\n";
print " <arg line=\"-s \"/>\n";
print " <fileset dir=\"\${BUILD_ROOT}\" >\n";
foreach my $srccomp (sort {$a->{compname} cmp $b->{compname}} @cyclebusters)
{
print " <include name=\"$srccomp->{compname}.dll\" />\n";
}
print " </fileset>\n";
print " </apply>\n";
print "\n\n";
}
#------------------------------------------
sub checkIfAlreadyScanned($$)
{
my ($path, $fname) = @_;
if (exists($vbpfiles{$fname}))
{
print "ERR: $fname has already been scanned!\n";
print " it was found here: ", $vbpfiles{$fname}{fqpath}, "\n";
print " and here : $path\n";
exit(1);
}
}
#------------------------------------------
sub initEntry($$$$)
{
my ($path, $dir, $vbpfname, $comp) = @_;
$vbpfiles{$comp}{compname} = $comp;
$vbpfiles{$comp}{vbpfname} = $vbpfname;
$vbpfiles{$comp}{fqpath} = $path;
$vbpfiles{$comp}{numoutrefs}= 0;
$vbpfiles{$comp}{numfilled} = 0;
$vbpfiles{$comp}{numinrefs} = 0;
$vbpfiles{$comp}{vbrefs} = {};
}
#------------------------------------------
my %CommonReferences =
(
aspemail => 1,
asphttp => 1,
c1smatnt => 1,
cdosys => 1,
comsvcs => 1,
comadmin => 1,
dzactx => 1,
duzactx => 1,
dyncrypto152 => 1,
msxml3 => 1,
msxml => 1,
msado15 => 1,
msadox => 1,
mssoap1 => 1,
mtxas => 1,
msderun => 1,
mqoa => 1,
pfprocom => 1,
scrrun => 1,
sqldmo => 1,
shdocvw => 1,
trigobjs => 1,
xblkld2 => 1,
fontmetrics => 1, # not really a common one, but it isn't a vb component
ctivbutility => 1, # ditto
) ;
#------------------------------------------
sub addReference($$$)
{
my ($fname, $clsid, $mush) = @_;
# remove: ..\
$mush =~ s/\.\.\\//g;
#print " found mush =$mush\n";
my ($comp) = $mush =~ /([^\\]+)\.dll$/;
return if ! defined $comp;
return if exists($CommonReferences{$comp});
print "\n$fname.vbp: reference to an unrecognized 3rd party component '$comp' was found.\n\tPath: '$mush'\n" if ($mush !~ /^build\\/);
#print " found mush =$mush\n";
#print " found comp ='$comp'\n";
#print " found clsid=$clsid\n";
# {refname} : name of the referenced file
# {clsid} : the clsid of the referenced file
# {fulfilled}: bool flag
$vbpfiles{$fname}{numoutrefs}++;
$vbpfiles{$fname}{vbrefs}{$comp}{clsid} = $clsid;
$vbpfiles{$fname}{vbrefs}{$comp}{fulfilled}= 0;
}
#------------------------------------------
sub parseFile($$)
{
my ($path, $fname) = @_;
open (FH, "< $path");
my @lines = <FH>;
close(FH);
##e.g. Reference=*\G{C5A5A399-D8B7-11D3-A7EA-0010A4E201EA}#4.1#0#..\..\..\build\groupone.dll#GroupOne
foreach my $line (@lines)
{
my ($clsid, $mush) = $line =~ /^\s*Reference=\*\\G({[^}]*})#.*#.*#(.*)#.*$/;
die "bad pattern here->" if (defined $clsid and ! defined $mush) or (! defined $clsid and defined $mush);
if (defined $clsid)
{
addReference($fname, lc $clsid, lc $mush);
}
}
}
#------------------------------------------
sub processVbp($$$$)
{
my ($path, $dir, $vbpfname, $fname) = @_;
checkIfAlreadyScanned($path, $fname);
initEntry($path, $dir, $vbpfname, $fname);
parseFile($path, $fname);
}
#------------------------------------------
sub scanFile
{
return if -d $File::Find::name;
my $vbpfile = $_;
return if $vbpfile !~ /\.vbp$/i;
$vbpfile =~ s/\//\\/g;
my $fqpath = $File::Find::name;
$fqpath =~ s/\//\\/g;
my ($fname) = $vbpfile =~ /^(.*)\.vbp$/i;
$verbose >= $VB_MED ? print "scanning $fname\n" : print ".";
processVbp(lc $fqpath, lc $File::Find::dir, lc $vbpfile, lc $fname);
}
#------------------------------------------
sub countNumInReferences($)
{
my ($incomp) = @_;
my $count = 0;
foreach my $srccomp (sort keys %vbpfiles)
{
my $rrefs = $vbpfiles{$srccomp}{vbrefs};
foreach my $comp (sort keys %{$rrefs})
{
$count++ if $comp eq $incomp;
}
}
return $count;
}
#------------------------------------------
sub adjustNumInRefs()
{
foreach my $srccomp (sort keys %vbpfiles)
{
print ".";
my $comp = $vbpfiles{$srccomp}{compname};
my $count = countNumInReferences($comp);
$vbpfiles{$srccomp}{numinrefs} = $count;
}
print "\n";
}
#------------------------------------------
sub moveComponentToCycleBusters($)
{
my ($comp) = @_;
print "CycleBuster : $vbpfiles{$comp}{compname}\n" if $verbose >= $VB_LOW;
push @cyclebusters, $vbpfiles{$comp};
delete $vbpfiles{$comp};
}
#------------------------------------------
sub moveComponentToDepends($)
{
my ($comp) = @_;
print "Moving $comp to Depends list\n" if $verbose >= $VB_ALL;
push @depends, $vbpfiles{$comp};
delete $vbpfiles{$comp};
}
#------------------------------------------
sub moveZeroDependencyComponents()
{
print "Moving zero dependency components to Depends list\n" if $verbose >= $VB_MED;
foreach my $srccomp (sort keys %vbpfiles)
{
next if $vbpfiles{$srccomp}{numoutrefs} != 0;
print "ZeroDependency: $srccomp\n" if $verbose >= $VB_LOW;
moveComponentToDepends($srccomp);
}
print "done: Moving zero dependency components to Depends list\n" if $verbose >= $VB_MED;
}
#------------------------------------------
sub moveStandAloneComponents()
{
print "Moving standalone components to Depends list\n" if $verbose >= $VB_MED;
foreach my $srccomp (sort keys %vbpfiles)
{
next if $vbpfiles{$srccomp}{numinrefs} != 0 or $vbpfiles{$srccomp}{numoutrefs} != 0;
print "StandAlone : $srccomp\n" if $verbose >= $VB_LOW;
moveComponentToDepends($srccomp);
}
print "done: moving standalone components to Depends list\n" if $verbose >= $VB_MED;
}
#------------------------------------------
sub moveRemainingComponentsToCycleBusters()
{
foreach my $srccomp (sort keys %vbpfiles)
{
moveComponentToCycleBusters($srccomp);
}
}
#------------------------------------------
sub clearAllFulfilledFlags()
{
foreach my $srccomp (keys %vbpfiles)
{
$vbpfiles{$srccomp}{numfilled} = 0;
my $rrefs = $vbpfiles{$srccomp}{vbrefs};
foreach my $comp (keys %{$rrefs})
{
$vbpfiles{$srccomp}{vbrefs}{$comp}{fulfilled} = 0;
}
}
}
#------------------------------------------
sub setFulfilledFlagsFor($)
{
my ($tgtcomp) = @_;
print "Setting fulfilled flags for: $tgtcomp\n" if $verbose >= $VB_ALL;
foreach my $srccomp (keys %vbpfiles)
{
my $rrefs = $vbpfiles{$srccomp}{vbrefs};
foreach my $comp (keys %{$rrefs})
{
next if ($comp ne $tgtcomp);
$vbpfiles{$srccomp}{numfilled}++;
$vbpfiles{$srccomp}{vbrefs}{$comp}{fulfilled} = 1;
}
}
print "done: setting fulfilled flags for: $tgtcomp\n" if $verbose >= $VB_ALL;
}
#------------------------------------------
sub setFulfilledFlags()
{
foreach my $srccomp (@depends)
{
setFulfilledFlagsFor($srccomp->{compname});
}
foreach my $srccomp (@cyclebusters)
{
setFulfilledFlagsFor($srccomp->{compname});
}
}
#------------------------------------------
sub moveFulfilledComponents()
{
print "Moving fulfilled components to Depends list\n" if $verbose >= $VB_MED;
my $actiontaken = 0;
foreach my $srccomp (sort keys %vbpfiles)
{
next if $vbpfiles{$srccomp}{numfilled} != $vbpfiles{$srccomp}{numoutrefs};
print "FulFilled : $srccomp\n" if $verbose >= $VB_LOW;
moveComponentToDepends($srccomp);
$actiontaken++;
}
print "done: moved $actiontaken fulfilled components to Depends list\n" if $verbose >= $VB_MED;
return $actiontaken;
}
#------------------------------------------
sub moveAllFulfilledComponents()
{
clearAllFulfilledFlags();
setFulfilledFlags();
if ($verbose >= $VB_ALL)
{
print "\n\n---> after fulfilled flags are set\n";
dumpSummaryDependencyList();
dumpSummaryCycleBustersList();
dumpVbpFiles();
print "---> done after fulfilled flags are set\n";
}
return moveFulfilledComponents();
}
#------------------------------------------
sub findMostUsedComponent
{
my @complist = @_;
my $maxcomp;
my $maxinref = -1;
foreach my $comp (@complist)
{
print " $vbpfiles{$comp}{numinrefs} components use $comp\n" if $verbose >= $VB_MED;
next if $vbpfiles{$comp}{numinrefs} <= $maxinref ;
$maxcomp = $comp;
$maxinref = $vbpfiles{$comp}{numinrefs};
}
return $maxcomp;
}
#------------------------------------------
sub findPossibleFulfilled($)
{
my ($srccomp) = @_;
my $count = 0;
foreach my $comp (keys %vbpfiles)
{
next if $srccomp eq $comp;
next if ($vbpfiles{$comp}{numfilled} + 1 != $vbpfiles{$comp}{numoutrefs});
my $rrefs = $vbpfiles{$comp}{vbrefs};
foreach my $calledcomp (keys %{$rrefs})
{
next if $vbpfiles{$comp}{vbrefs}{$calledcomp}{fulfilled} == 1;
next if ($calledcomp ne $srccomp);
#print " $srccomp satisfies $comp \n";
$count++;
last;
}
}
return $count;
}
#------------------------------------------
sub findMostFulfillingComponent()
{
my $maxcomp;
my $maxcount = 0;
my %ties = ();
foreach my $comp (keys %vbpfiles)
{
my $count = findPossibleFulfilled($comp);
#print "relationships satisfied: $count (by $comp)\n" if $count > 0;
if ($count >= $maxcount)
{
if ($count > $maxcount)
{
%ties = ();
$maxcomp = $comp;
$maxcount = $count;
}
$ties{$comp}++;
}
}
if (!(defined $maxcomp) or scalar keys %ties > 1)
{
print "There was a tie; searching for most used component...\n" if $verbose >= $VB_MED;
$maxcomp = findMostUsedComponent(keys %ties);
}
print "most fulfilling component: $maxcomp\n" if $verbose >= $VB_MED;
return $maxcomp;
}
#------------------------------------------
sub createDependencyList()
{
moveStandAloneComponents();
moveZeroDependencyComponents();
while (moveAllFulfilledComponents()) {}
while (scalar keys %vbpfiles != 0)
{
my $comp = findMostFulfillingComponent();
moveComponentToCycleBusters($comp);
while (moveAllFulfilledComponents()) {}
}
}
#-----
## main
#todo:
# resolve srccomponents clsid if possible: use calling components references...
my $dir = $ARGV[0];
$dir = "c:\\dev\\src\\vb";
print "Scanning--->\n";
find (\&scanFile, $dir);
my $numvbpfiles = scalar keys %vbpfiles;
print "\nFinding number of in references--->\n";
adjustNumInRefs();
# dumpVbpFiles();
if ($verbose >= $VB_ALL)
{
print "---------------------------------------\n";
print "-- Finished gathering information -----\n";
print "---------------------------------------\n\n";
dumpVbpFiles();
print "---------------------------------------\n";
print "-- Finished gathering information -----\n";
print "---------------------------------------\n\n";
}
print "\nCalculating dependency list--->\n" if $verbose >= $VB_MED;
createDependencyList();
if ($verbose == $VB_LOW)
{
dumpSummaryDependencyList();
dumpSummaryCycleBustersList();
}
elsif ($verbose >= $VB_MED)
{
dumpDependencyList();
dumpCycleBusters();
}
die "vbpfiles list should be empty!" if scalar keys %vbpfiles != 0;
dumpAntLists();
print "---------------------------------------\n";
print "-- statistics:\n";
print " number of components : $numvbpfiles\n";
print " number of cyclebusters : ", scalar @cyclebusters, "\n";
print " number of dependencies : ", scalar @depends, "\n";
__END__
:endofperl
|