From a6fef442dd3a479f3f043afd6920fb95e02df1f2 Mon Sep 17 00:00:00 2001 From: Xiaoqiang Wang Date: Wed, 6 May 2020 11:27:05 +0200 Subject: [PATCH 1/4] translated from tcl to perl --- App/tools/expandDBD.pl | 92 +++++++++++++ App/tools/getVersion.pl | 283 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 375 insertions(+) create mode 100755 App/tools/expandDBD.pl create mode 100755 App/tools/getVersion.pl diff --git a/App/tools/expandDBD.pl b/App/tools/expandDBD.pl new file mode 100755 index 0000000..08f6961 --- /dev/null +++ b/App/tools/expandDBD.pl @@ -0,0 +1,92 @@ +#!/usr/bin/env perl + +use warnings; +use strict; +use 5.010; + +use File::Basename qw/basename/; +use File::Spec::Functions qw/catfile/; + +my $epicsversion = 3.14; +my $quiet = 0; +my @searchpath = (); +my @filesDone = (); +my @filesInput = (); + +while (@ARGV) { + my $arg = shift @ARGV; + if ($arg =~ /^-(\d*(\.\d*)?)$/) { $epicsversion = $1; } + elsif ($arg eq "-q") { $quiet = 1; } + elsif ($arg =~ /^-I$/) { push @searchpath, shift @ARGV; } + elsif ($arg =~ /^-I(.*)$/) { push @searchpath, $1; } + else { push @filesInput, $arg; } +} +## +## Search given dbd file from @searchpath list. +## If it is not found, return the file name as it is. +## +sub finddbd { + my $name = $_[0]; + + foreach my $dir (@searchpath) { + my $fullname = catfile($dir, $name); + if ( -f $fullname) { + return $fullname; + } + } + + return $name; +} + +## +## Read a dbd file and dump its contents to stdout. +## File after "include" directive is read in too. +## +sub scanfile { + my $fname = $_[0]; + my $name = basename($fname); + + if (grep $name eq $_, @filesDone) { + if (!$quiet) { + say STDERR "Info: skipping duplicate file \"$name\" from command line"; + } + return; + } + + if ($name ne "dbCommon.dbd") { + push @filesDone, $name; + } + + if (!(open FILE, "<", finddbd($name))) { + say STDERR "Error openning file \"$name\" for reading: $!"; + return; + } + + foreach my $line () { + if ($line =~ /^[ \t]*(#|%|$)/) { + # skip + } + elsif ($line =~ /include[ \t]+"?([^"]*)"?/) { + scanfile($1); + } + elsif ($line =~ /(registrar|variable|function)[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { + if ($epicsversion > 3.13) { + say "$1($2)"; + } + } + elsif ($line =~ /variable[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*,[ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { + if ($epicsversion > 3.13) { + say "variable($1,$2)" + } + } + else { + print $line; + } + } + + close FILE; +} + +foreach my $fname (@filesInput) { + scanfile $fname; +} diff --git a/App/tools/getVersion.pl b/App/tools/getVersion.pl new file mode 100755 index 0000000..ffe34f0 --- /dev/null +++ b/App/tools/getVersion.pl @@ -0,0 +1,283 @@ +#!/usr/bin/env perl + +use warnings; +use strict; +use 5.010; + +use File::Glob qw/bsd_glob/; +use IPC::Open3; + +# cvs status parsing state +use constant { + GLOBAL => 0, + FILE => 1, + SKIP => 2 +}; + +my $version; +my $debug = 0; + +# Check all files in top directory and all files specified explicitly in subdirectories +my @files = glob("GNUmakefile makefile Makefile *.c *.cc *.cpp *.h *.dbd *.st *.stt *.gt"); +# perl glob keeps non-wildcard names even they don't match, which are removed manually. +@files = grep(-f, @files); +my @statusinfo; + +while (@ARGV) { + my $arg = shift @ARGV; + if ($arg eq "-d") { + $debug = 1; + } else { + push @files, $arg; + } +} +# concatenate the files list to one space separatd string +my $files = join(' ', @files); + +sub check_output { + my ($child_stdin, $child_stdout, $child_stderr); + chomp(my $command = $_[0]); + + # start the child process and wait for it to finish + my $child_pid = open3($child_stdin, $child_stdout, $child_stderr, $command); + waitpid($child_pid, 0); + if ($? != 0) { + my $error; + foreach (<$child_stdout>) { + $error .= $_; + } + die $error; + } + + # read child process output + my @output = (); + foreach my $line (<$child_stdout>) { + push @output, $line; + } + + return @output; +} + +sub parse_cvs_output { + my @output = @{$_[0]}; + my $scope = GLOBAL; + my $file; + my %rev; + my %tag; + my ($major, $minor, $patch); + + foreach my $line (@output) { + chomp($line); + if ($scope == SKIP) { + if ($line =~ /=================/) { + $scope = GLOBAL; + } + } + elsif ($scope == FILE) { + if ($line =~ /Working revision:/) { + $rev{$file} = (split " ", $line)[2]; + } + elsif ($line =~ /Sticky Tag:.*_([0-9]+)_([0-9]+)(_([0-9]+))?[ \t]+\(revision: /) { + $major = $1; + $minor = $2; + $patch = $4 || 0; + $tag{$file} = (split " ", $line)[2] . " (sticky)"; + $scope = SKIP; + } + elsif ($line =~ /_([0-9]+)_([0-9]+)(_([0-9]+))?[ \t]+\(revision: ([\.0-9]+)\)/) { + if ($rev{$file} eq $5) { + my $Major = $1; + my $Minor = $2; + my $Patch = $4 || 0; + if (!defined($major) || + $Major > $major || + ($Major == $major && ($Minor > $minor + || ($Minor == $minor && $Patch > $patch)))) { + $major = $Major; + $minor = $Minor; + $patch = $Patch; + $tag{$file} = (split " ", $line)[0]; + } + } + } + elsif ($line =~ /=================/) { + if (!defined($major)) { + say STDERR "checking $file: revision $rev{$file} not tagged => version test"; + $version = "test"; + } else { + say STDERR "checking $file: revision $rev{$file} tag $tag{$file} => version $major.$minor.$patch"; + if (!defined($version)) { + $version = "$major.$minor.$patch"; + } else { + if ($version ne "$major.$minor.$patch") { + $version = "test"; + } + } + } + $scope = GLOBAL; + } + } + elsif ($scope == GLOBAL) { + if ($line =~ /there is no version here/) { + return; + } + elsif ($line =~ /cvs status: failed/) { + say STDERR "Error: $line"; + return; + } + elsif ($line =~ /no such directory `(.*)'/) { + say STDERR "checking directory $1: so such directory"; + return; + } + elsif ($line =~ /cvs \[status aborted\]: there is no version here/) { + return; + } + elsif ($line =~ /^File: (\S+)\s+Status: Up-to-date/) { + $file = $1; + $major = undef(); + $minor = undef(); + $patch = undef(); + $scope = FILE; + } + elsif ($line =~ /^File: (\S+)\s+Status: (.*)/) { + $file = $1; + say STDERR "checking $file: $2 => verson test"; + $version = "test"; + } + elsif ($line =~ /^\? .*/) { + $file = (split " ", $line)[1]; + say STDERR "checking $file: not in cvs => version test"; + $version = "test"; + } + } + } +} + +sub parse_git_output { + my @output = @{$_[0]}; + + foreach my $line (@output) { + chomp($line); + if ($line =~ /fatal: Not a git repository/) { + return; + } + elsif ($line =~ /^\?\? (.*)/) { + say STDERR "$1: not in git => version test"; + $version = "test"; + } + elsif ($line =~ /^ M (.*)/) { + say STDERR "$1: locally modified => version test"; + $version = "test"; + } + elsif ($line =~ /^D (.*)/) { + say STDERR "$1: deleted (or renamed) but not committed => version test"; + $version = "test"; + } + elsif ($line =~ /^ D (.*)/) { + say STDERR "$1: locally deleted => version test"; + $version = "test"; + } + elsif ($line =~ /^A (.*)/) { + say STDERR "$1: locally added => version test"; + $version = "test"; + } + elsif ($line =~ /^AM (.*)/) { + say STDERR "$1: locally added and modified => version test"; + $version = "test"; + } + elsif ($line =~ /^([ MADRCU][ MADRCU]) (.*)/) { + say STDERR "$2: $1 (whatever that means) => version test"; + $version = "test"; + } + elsif ($line =~ /fatal: No names found/) { + say STDERR "no tag on this version => version test"; + $version = "test"; + } + elsif ($line =~ /^([0-9]+)\.([0-9]+)(\.([0-9]+))?$/) { + my $major = $1; + my $minor = $2; + my $patch = $4 || "0"; + $version = "$major.$minor.$patch"; + say STDERR "checking tag $line => version $version"; + } + elsif ($line =~ /[a-zA-Z]+[a-zA-Z0-9]*_([0-9]+)_([0-9]+)(_([0-9]+))?$/) { + my $major = $1; + my $minor = $2; + my $patch = $4 || "0"; + $version = "$major.$minor.$patch"; + say STDERR "checking tag $line => version $version"; + } + elsif ($line =~ /(.*[0-9]+[_.][0-9]+([_.][0-9]+)?)-([0-9]+)-g/) { + $version = "test"; + say STDERR "tag $1 is $3 commits old => version test"; + } + elsif ($line =~ /Your branch is ahead of '(.*)\/(.*)'/) { + say STDERR "branch \"$2\" not yet pushed to remote \"$1\" => version test"; + say STDERR "try: git push --tags $1 $2"; + $version = "test"; + } + } +} + +if ($debug) { + say STDERR "checking $files"; +} + +eval { + # fails if git command exits with error + if ($debug) { + say STDERR "git status --porcelain $files" + } + @statusinfo = check_output("git status --porcelain $files"); + parse_git_output(\@statusinfo); + if ($version) { + say $version; + exit; + } + + if ($debug) { + say STDERR "git describe --tags HEAD"; + } + @statusinfo = check_output("git describe --tags HEAD"); + parse_git_output(\@statusinfo); + if (!defined($version)) { + say STDERR "Could not find out version tag => version test"; + $version = "test"; + } + + if ($version ne "test") { + if ($debug) { + say STDERR "git status"; + } + @statusinfo = check_output("git status"); + parse_git_output(\@statusinfo); + } + + say $version; + exit; +}; + +eval { +# cvs bug: calling cvs status for files in other directories spoils status +# information for local files. +# fix: check local and non local files separately + + # fails if we have no cvs or server has a problem + if ($debug) { + say STDERR "cvs status -l -v $files;" + } + @statusinfo = check_output("cvs status -l -v $files"); + # mark the finsh of the last file for the parser + push @statusinfo, "==================================================================="; + parse_cvs_output(\@statusinfo); + if (!defined($version)) { + say STDERR "Could not find out version tag => version test"; + $version = "test"; + } + + say $version; + exit; +}; + +say STDERR "No repository found => version test"; +say "test"; From f5c797202d8fa47f247039976cabf6994a62be8e Mon Sep 17 00:00:00 2001 From: Xiaoqiang Wang Date: Thu, 7 May 2020 09:05:47 +0200 Subject: [PATCH 2/4] match error prints with the tcl script --- App/tools/expandDBD.pl | 89 ++++++++++++++++++++++++------------------ 1 file changed, 51 insertions(+), 38 deletions(-) diff --git a/App/tools/expandDBD.pl b/App/tools/expandDBD.pl index 08f6961..d95df85 100755 --- a/App/tools/expandDBD.pl +++ b/App/tools/expandDBD.pl @@ -10,23 +10,24 @@ use File::Spec::Functions qw/catfile/; my $epicsversion = 3.14; my $quiet = 0; my @searchpath = (); -my @filesDone = (); +my %filesDone = (); my @filesInput = (); while (@ARGV) { my $arg = shift @ARGV; - if ($arg =~ /^-(\d*(\.\d*)?)$/) { $epicsversion = $1; } + if ($arg =~ /^-\d/) { $epicsversion = substr($arg, 1); } elsif ($arg eq "-q") { $quiet = 1; } elsif ($arg =~ /^-I$/) { push @searchpath, shift @ARGV; } elsif ($arg =~ /^-I(.*)$/) { push @searchpath, $1; } else { push @filesInput, $arg; } } + ## ## Search given dbd file from @searchpath list. ## If it is not found, return the file name as it is. ## sub finddbd { - my $name = $_[0]; + my $name = shift; foreach my $dir (@searchpath) { my $fullname = catfile($dir, $name); @@ -43,50 +44,62 @@ sub finddbd { ## File after "include" directive is read in too. ## sub scanfile { - my $fname = $_[0]; - my $name = basename($fname); + my $name = shift; # dbd file to read + my $includer = shift; # dbd file and lineno where this dbd file is included. + my $lineno = shift; # they are undef for files from command line. - if (grep $name eq $_, @filesDone) { + my $base = basename($name); + + if (exists($filesDone{$base})) { if (!$quiet) { - say STDERR "Info: skipping duplicate file \"$name\" from command line"; - } - return; - } - - if ($name ne "dbCommon.dbd") { - push @filesDone, $name; - } - - if (!(open FILE, "<", finddbd($name))) { - say STDERR "Error openning file \"$name\" for reading: $!"; - return; - } - - foreach my $line () { - if ($line =~ /^[ \t]*(#|%|$)/) { - # skip - } - elsif ($line =~ /include[ \t]+"?([^"]*)"?/) { - scanfile($1); - } - elsif ($line =~ /(registrar|variable|function)[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { - if ($epicsversion > 3.13) { - say "$1($2)"; + if ($includer) { + say STDERR "Info: skipping duplicate file $name included from $includer line $lineno"; + } + else { + say STDERR "Info: skipping duplicate file $name from command line"; } } - elsif ($line =~ /variable[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*,[ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { - if ($epicsversion > 3.13) { - say "variable($1,$2)" - } + return 1; + } + + if ($base ne "dbCommon.dbd") { + $filesDone{$base} = 1; + } + + my $fh; + if (!(open $fh, "<", finddbd($name))) { + if ($includer) { + say STDERR "ERROR: file $name not found in path \"@searchpath\" called from $includer line $lineno"; } else { - print $line; + say STDERR "ERROR: file $name not found in path \"@searchpath\""; + } + return 0; + } + + foreach (my $n=1;<$fh>;$n++) { + chomp; + + if (/^[ \t]*(#|%|$)/) { + # skip + } + elsif (/include[ \t]+"?([^"]*)"?/) { + return 0 unless scanfile($1, $name, $n); + } + elsif (/(registrar|variable|function)[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { + say "$1($2)" if $epicsversion gt 3.13; + } + elsif (/variable[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*,[ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { + say "variable($1,$2)" if $epicsversion gt 3.13; + } + else { + say; } } - close FILE; + return 1; } -foreach my $fname (@filesInput) { - scanfile $fname; +foreach my $name (@filesInput) { + exit 1 unless scanfile($name); } From 63bb686dbd09beb84d77361063ccf6b9ffb7b4f8 Mon Sep 17 00:00:00 2001 From: Xiaoqiang Wang Date: Fri, 8 May 2020 09:04:18 +0200 Subject: [PATCH 3/4] handle strict version comparison --- App/tools/expandDBD.pl | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/App/tools/expandDBD.pl b/App/tools/expandDBD.pl index d95df85..05aafeb 100755 --- a/App/tools/expandDBD.pl +++ b/App/tools/expandDBD.pl @@ -7,7 +7,7 @@ use 5.010; use File::Basename qw/basename/; use File::Spec::Functions qw/catfile/; -my $epicsversion = 3.14; +my $epicsversion = 0x030E0000; # 3.14 my $quiet = 0; my @searchpath = (); my %filesDone = (); @@ -15,13 +15,30 @@ my @filesInput = (); while (@ARGV) { my $arg = shift @ARGV; - if ($arg =~ /^-\d/) { $epicsversion = substr($arg, 1); } + if ($arg =~ /^-(\d+(.\d+){0,3})$/) { $epicsversion = parseVersion($1); } elsif ($arg eq "-q") { $quiet = 1; } elsif ($arg =~ /^-I$/) { push @searchpath, shift @ARGV; } elsif ($arg =~ /^-I(.*)$/) { push @searchpath, $1; } else { push @filesInput, $arg; } } +## +## Convert version string of version.revision.modification.patch format +## to integer format 0Xvvrrmmpp (in hexadecimal) +## 3.14.12.8 -> 0x030E0C08 +## 7.0.3 -> 0x07000300 +## This requires all parts of version number are in range 0-255, +## which is true for EPICS base version number. +## +sub parseVersion { + my @vi = split(/\./, shift); # version integers list + my $vh = 0; # hexadecimal version + foreach my $i (0..$#vi) { + $vh |= $vi[$i] << (8 * (3-$i)); + } + return $vh; +} + ## ## Search given dbd file from @searchpath list. ## If it is not found, return the file name as it is. @@ -87,10 +104,10 @@ sub scanfile { return 0 unless scanfile($1, $name, $n); } elsif (/(registrar|variable|function)[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { - say "$1($2)" if $epicsversion gt 3.13; + say "$1($2)" if $epicsversion > 0x030D0000; # 3.13 } elsif (/variable[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*,[ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)/) { - say "variable($1,$2)" if $epicsversion gt 3.13; + say "variable($1,$2)" if $epicsversion > 0x030D0000; # 3.13 } else { say; From 6c51fe615700545560eec0e2c3dd1b03188221ab Mon Sep 17 00:00:00 2001 From: Dirk Zimoch Date: Fri, 15 May 2020 11:12:36 +0200 Subject: [PATCH 4/4] use new perl scripts --- App/tools/driver.makefile | 4 +- App/tools/expandDBD.tcl | 115 --------------- App/tools/getVersion.tcl | 287 -------------------------------------- 3 files changed, 2 insertions(+), 404 deletions(-) delete mode 100755 App/tools/expandDBD.tcl delete mode 100755 App/tools/getVersion.tcl diff --git a/App/tools/driver.makefile b/App/tools/driver.makefile index 4d6d680..6df1079 100644 --- a/App/tools/driver.makefile +++ b/App/tools/driver.makefile @@ -149,7 +149,7 @@ SUBMODULES:=$(foreach f,$(wildcard .gitmodules),$(shell awk '/^\[submodule/ { pr VERSIONCHECKFILES = $(filter-out /% -none-, $(USERMAKEFILE) $(wildcard *.db *.template *.subs *.dbd *.cmd *.iocsh) VERSIONCHECKFILES += ${SOURCES} ${DBDS} ${TEMPLATES} ${SCRIPTS} $($(filter SOURCES_% DBDS_%,${.VARIABLES}))) VERSIONCHECKFILES += ${SUBMODULES} -VERSIONCHECKCMD = ${MAKEHOME}/getVersion.tcl ${VERSIONDEBUGFLAG} ${VERSIONCHECKFILES} +VERSIONCHECKCMD = ${MAKEHOME}/getVersion.pl ${VERSIONDEBUGFLAG} ${VERSIONCHECKFILES} LIBVERSION = $(or $(filter-out test,$(shell ${VERSIONCHECKCMD} 2>/dev/null)),${USER},test) VERSIONDEBUGFLAG = $(if ${VERSIONDEBUG}, -d) @@ -887,7 +887,7 @@ MODULEINFOS: # because it has too strict checks to be used for a loadable module. ${MODULEDBD}: ${DBDFILES} @echo "Expanding $@" - ${MAKEHOME}expandDBD.tcl -$(basename ${EPICSVERSION}) ${DBDEXPANDPATH} $^ > $@ + ${MAKEHOME}expandDBD.pl -$(basename ${EPICSVERSION}) ${DBDEXPANDPATH} $^ > $@ # Install everything. INSTALL_LIBS = $(addprefix ${INSTALL_LIB}/,${MODULELIB} $(notdir ${SHRLIBS})) diff --git a/App/tools/expandDBD.tcl b/App/tools/expandDBD.tcl deleted file mode 100755 index 0539876..0000000 --- a/App/tools/expandDBD.tcl +++ /dev/null @@ -1,115 +0,0 @@ -#!/usr/bin/tclsh - -package require Tclx - -set global_context [scancontext create] - -set epicsversion 3.14 -set quiet 0 -set recordtypes 0 -set seachpath {} -set filesDone {} - -while {[llength $argv]} { - switch -glob -- [lindex $argv 0] { - "-[0-9]*" { set epicsversion [string range [lindex $argv 0] 1 end]} - "-q" { set quiet 1 } - "-r" { set recordtypes 1; set quiet 1 } - "-I" { lappend seachpath [lindex $argv 1]; set argv [lreplace $argv 0 1]; continue } - "-I*" { lappend seachpath [string range [lindex $argv 0] 2 end] } - "--" { set argv [lreplace $argv 0 0]; break } - "-*" { puts stderr "Warning: Unknown option [lindex $argv 0] ignored" } - default { break } - } - set argv [lreplace $argv 0 0] -} - -proc opendbd {name} { - global seachpath - foreach dir $seachpath { - if ![catch { - set file [open [file join $dir $name]] - }] { - return $file - } - } - return -code error "file $name not found" -} - -scanmatch $global_context {^[ \t]*(#|%|$)} { - continue -} - -if {$recordtypes} { - scanmatch $global_context {include[ \t]+"?((.*)Record.dbd)"?} { - if ![catch { - close [opendbd $matchInfo(submatch0)] - }] { - puts $matchInfo(submatch1) - } - continue -} - -} else { - - scanmatch $global_context {(registrar|variable|function)[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)} { - global epicsversion - if {$epicsversion > 3.13} {puts $matchInfo(submatch0)($matchInfo(submatch1))} - } - scanmatch $global_context {variable[ \t]*\([ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*,[ \t]*"?([a-zA-Z0-9_]+)"?[ \t]*\)} { - global epicsversion - if {$epicsversion > 3.13} {puts variable($matchInfo(submatch0),$matchInfo(submatch1))} - } - - scanmatch $global_context { - puts $matchInfo(line) - } -} - -scanmatch $global_context {include[ \t]+"?([^"]*)"?} { - global seachpath - global FileName - global quiet - if [catch { - includeFile $global_context $matchInfo(submatch0) - } msg] { - if {!$quiet} { - puts stderr "ERROR: $msg in path \"$seachpath\" called from $FileName($matchInfo(handle)) line $matchInfo(linenum)" - exit 1 - } - } - continue -} - -proc includeFile {context filename} { - global global_context FileName filesDone matchInfo quiet - set basename [file tail $filename] - if {[lsearch $filesDone $basename ] != -1} { - if {!$quiet} { - puts stderr "Info: skipping duplicate file $basename included from $FileName($matchInfo(handle))" - } - return - } - if {$filename != "dbCommon.dbd"} { lappend filesDone [file tail $filename] } - set file [opendbd $filename] - set FileName($file) $filename - #puts "#include $filename from $FileName($matchInfo(handle))" - scanfile $context $file - close $file -} - -foreach filename $argv { - global filesDone quiet - set basename [file tail $filename] - if {[lsearch $filesDone $basename] != -1} { - if {!$quiet} { - puts stderr "Info: skipping duplicate file $basename from command line" - } - continue - } - if {$basename != "dbCommon.dbd"} { lappend filesDone $basename } - set file [open $filename] - set FileName($file) $filename - scanfile $global_context $file - close $file -} diff --git a/App/tools/getVersion.tcl b/App/tools/getVersion.tcl deleted file mode 100755 index b481adf..0000000 --- a/App/tools/getVersion.tcl +++ /dev/null @@ -1,287 +0,0 @@ -#!/usr/bin/tclsh - -package require Tclx - -set debug 0 - -set global_context [scancontext create] -set file_context [scancontext create] -set skip_context [scancontext create] - -scanmatch $global_context {there is no version here} { - return -} - -scanmatch $global_context {cvs status: failed} { - puts stderr "Error: $matchInfo(line)" - return -} - -scanmatch $global_context {no such directory `(.*)'} { - puts stderr "checking directory $matchInfo(submatch0): so such directory" - return -} - -scanmatch $global_context {cvs [status aborted]: there is no version here} { - return -} - -scanmatch $global_context {^File: .*Up-to-date} { - set file [lindex $matchInfo(line) 1] - puts -nonewline stderr "checking $file: " - catch {unset major minor patch} - scanfile $file_context $matchInfo(handle) - if {![info exists major]} { - puts stderr "revision $rev($file) not tagged => version test" - set version test - continue - } - puts stderr "revision $rev($file) tag $tag($file) => version $major.$minor.$patch" - if {![info exists version]} { - set version $major.$minor.$patch - } else { - if ![cequal $major.$minor.$patch $version] { - set version test - continue - } - } - continue -} - -scanmatch $global_context {^File: .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "checking $file: [lrange $matchInfo(line) 3 end] => version test" - set version test - continue -} - -scanmatch $global_context {^\? .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "checking $file: not in cvs => version test" - set version test - continue -} - -scanmatch $file_context {Working revision:} { - set rev($file) [lindex $matchInfo(line) 2] -} - -scanmatch $file_context {Sticky Tag:.*_([0-9]+)_([0-9]+)_([0-9]+)[ \t]+\(revision: } { - set major $matchInfo(submatch0) - set minor $matchInfo(submatch1) - set patch $matchInfo(submatch2) - set tag($file) "[lindex $matchInfo(line) 2] (sticky)" - scanfile $skip_context $matchInfo(handle) - return -} - -scanmatch $file_context {Sticky Tag:.*_([0-9]+)_([0-9]+)[ \t]+\(revision: } { - set major $matchInfo(submatch0) - set minor $matchInfo(submatch1) - set patch 0 - set tag($file) "[lindex $matchInfo(line) 2] (sticky)" - scanfile $skip_context $matchInfo(handle) - return -} - -scanmatch $file_context {_([0-9]+)_([0-9]+)(_([0-9]+))?[ \t]+\(revision: ([\.0-9]+)\)} { - if [cequal $rev($file) $matchInfo(submatch4)] { - set Major $matchInfo(submatch0) - set Minor $matchInfo(submatch1) - set Patch [expr $matchInfo(submatch3) + 0] - if {![info exists major] || - $Major>$major || - ($Major==$major && ($Minor>$minor - || ($Minor==$minor && $Patch>$patch)))} { - set major $Major - set minor $Minor - set patch $Patch - set tag($file) [lindex $matchInfo(line) 0] - } - } -} - -scanmatch $skip_context {=================} { - return -} - -scanmatch $file_context {=================} { - return -} - -set git_context [scancontext create] - -scanmatch $git_context {fatal: Not a git repository} { - return -} - -scanmatch $git_context {^\?\? .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: not in git => version test" - set version test - continue -} - -scanmatch $git_context {^ M .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: locally modified => version test" - set version test - continue -} - -scanmatch $git_context {^D .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: deleted (or renamed) but not committed => version test" - set version test - continue -} - -scanmatch $git_context {^ D .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: locally deleted => version test" - set version test - continue -} - -scanmatch $git_context {^A .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: locally added => version test" - set version test - continue -} - -scanmatch $git_context {^AM .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: locally added and modified => version test" - set version test - continue -} - -scanmatch $git_context {^([ MADRCU][ MADRCU]) .*} { - set file [lindex $matchInfo(line) 1] - puts stderr "$file: $matchInfo(submatch0) (whatever that means) => version test" - set version test - continue -} - -scanmatch $git_context {fatal: No names found} { - puts stderr "no tag on this version => version test" - set version test -} - -scanmatch $git_context {^([0-9]+)\.([0-9]+)(\.([0-9]+))?$} { - set major $matchInfo(submatch0) - set minor $matchInfo(submatch1) - set patch [expr $matchInfo(submatch3) + 0] - set version $major.$minor.$patch - puts stderr "checking tag $matchInfo(line) => version $version" -} - -scanmatch $git_context {[a-zA-Z]+[a-zA-Z0-9]*_([0-9]+)_([0-9]+)(_([0-9]+))?$} { - set major $matchInfo(submatch0) - set minor $matchInfo(submatch1) - set patch [expr $matchInfo(submatch3) + 0] - set version $major.$minor.$patch - puts stderr "checking tag $matchInfo(line) => version $version" -} - -scanmatch $git_context {(.*[0-9]+[_.][0-9]+([_.][0-9]+)?)-([0-9]+)-g} { - set version test - puts stderr "tag $matchInfo(submatch0) is $matchInfo(submatch2) commits old => version test" -} - -scanmatch $git_context {Your branch is ahead of '(.*)/(.*)'} { - puts stderr "branch \"$matchInfo(submatch1)\" not yet pushed to remote \"$matchInfo(submatch0)\" => version test" - puts stderr "try: git push --tags $matchInfo(submatch0) $matchInfo(submatch1)" - set version test -} - -if {[lindex $argv 0] == "-d"} { - set debug 1 - set argv [lrange $argv 1 end] -} - -# Check all files in top directory and all files specified explicitly in subdirectories - -set topfiles [glob -nocomplain GNUmakefile makefile Makefile *.c *.cc *.cpp *.h *.dbd *.st *.stt *.gt] - -if {$debug} { - puts stderr "checking $topfiles $argv" -} - - -if {[catch { - # fails if we have no git: - if {$debug} { - puts stderr "git status --porcelain $topfiles $argv" - } - set statusinfo [open "|git status --porcelain $topfiles $argv 2>@ stdout"] - scanfile $git_context $statusinfo - # fails if this is no git repo - close $statusinfo - - if [info exists version] { - puts $version - exit - } - - if {$debug} { - puts stderr "git describe --tags HEAD" - } - set statusinfo [open "|git describe --tags HEAD 2>@ stdout"] - scanfile $git_context $statusinfo - catch {close $statusinfo} - - if ![info exists version] { - puts stderr "Could not find out version tag => version test" - set version test - } - - if {$version != "test"} { - if {$debug} { - puts stderr "git status" - } - set statusinfo [open "|git status 2>@ stdout"] - scanfile $git_context $statusinfo - catch {close $statusinfo} - } - - puts $version - exit -}] && $debug} { puts stderr "git: $errorInfo" } - - -if {[catch { -# cvs bug: calling cvs status for files in other directories spoils status -# information for local files. -# fix: check local and non local files separately - - # fails if we have no cvs or server has a problem - if {$debug} { - puts stderr "cvs status -l -v $topfiles $argv" - } - set statusinfo [open "|cvs status -l -v $topfiles $argv 2>@ stdout"] - scanfile $global_context $statusinfo - # fails if this is no cvs repo - close $statusinfo - -# set files {} -# foreach file $argv { -# if {[file tail $file] != $file} { -# lappend files $file -# } -# } -# if [llength $files] { -# set statusinfo [open "|cvs status -l -v $files 2>@ stdout"] -# scanfile $global_context $statusinfo -# close $statusinfo -# } - - puts $version - exit -}] && $debug} { puts stderr "cvs: $errorInfo" } - -puts stderr "No repository found => version test" -puts "test" - -# $Header: /cvs/G/DRV/misc/App/tools/getVersion.tcl,v 1.3 2010/08/03 08:42:40 zimoch Exp $