diff --git a/src/tools/DBD/Base.pm b/src/tools/DBD/Base.pm index f840f6e54..3a316037f 100644 --- a/src/tools/DBD/Base.pm +++ b/src/tools/DBD/Base.pm @@ -16,15 +16,16 @@ our @EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x; -our $RXname = qr/ [a-zA-Z0-9_\-:.\[\]<>;]+ /x; +our $RXnchr = qr/ [a-zA-Z0-9_\-:.\[\]<>;] /x; +our $RXname = qr/ $RXnchr+ (?: [{}] $RXnchr+ )* /x; our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x; our $RXoct = qr/ 0 [0-7]* /x; -our $RXdqs = qr/ " (?: [^"] | \\" )* " /x; our $RXuint = qr/ [0-9]+ /x; our $RXint = qr/ -? $RXuint /x; our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /x; our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /x; our $RXnum = qr/ -? (?: [0-9]+ | [0-9]* \. [0-9]+ ) (?: [eE] [-+]? [0-9]+ )? /x; +our $RXdqs = qr/ " (?> \\. | [^"\\] )* " /x; our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs ) /x; our @context; @@ -93,7 +94,7 @@ sub escapeCcomment { sub escapeCstring { ($_) = @_; - # How to do this? + # FIXME: How to do this? return $_; } diff --git a/src/tools/test/Base.plt b/src/tools/test/Base.plt new file mode 100644 index 000000000..b56e11255 --- /dev/null +++ b/src/tools/test/Base.plt @@ -0,0 +1,98 @@ +#!/usr/bin/perl + +use lib '../..'; + +use Test::More tests => 127; + +use DBD::Base; +use DBD::Registrar; + +note "*** Testing DBD::Base class ***"; + +my $base = DBD::Base->new('test', 'Base class'); +isa_ok $base, 'DBD::Base'; +is $base->what, 'Base class', 'DBD Object type'; +is $base->name, 'test', 'Base class name'; + +my $base2 = DBD::Base->new('test2', 'Base class'); +isa_ok $base, 'DBD::Base'; +ok !$base->equals($base2), 'Different names'; + +my $reg = DBD::Registrar->new('test'); +ok !$base->equals($reg), 'Different types'; + +eval { + $base->add_comment('testing'); +}; +ok $@, 'add_comment died'; + +{ + local *STDERR; + my $warning = ''; + open STDERR, '>', \$warning; + $base->add_pod('testing'); + like $warning, qr/^Warning:/, 'add_pod warned'; + # Also proves that warnContext works +} + +note "*** Testing push/pop contexts ***"; +pushContext "a"; +pushContext "b"; +eval { + popContext "b"; +}; +ok !$@, "pop: Expected context didn't die"; + +eval { + popContext "b"; +}; +ok $@, "pop: Incorrect context died"; +# Also proves that dieContext dies properly + +note "*** Testing basic RXs ***"; + +# For help in debugging regex's, wrap tests below inside +# use re 'debugcolor'; +# ... +# no re; + +like($_, qr/^ $RXident $/x, "Good RXident: $_") + foreach qw(a A1 a111 z9 Z9 Z_999); +unlike($_, qr/^ $RXident $/x, "Bad RXident: $_") + foreach qw(. 1 _ : a. _: 9.0); + +like($_, qr/^ $RXname $/x, "Good RXname: $_") + foreach qw(a A1 a1:x _ -; Z[9] Z<999> a{x}b); +unlike($_, qr/^ $RXname $/x, "Bad RXname: $_") + foreach qw({x} a{x} {x}b @A 9.0% $x); + +like($_, qr/^ $RXhex $/x, "Good RXhex: $_") + foreach qw(0x0 0XA 0xAf 0x99 0xfedbca987654321 0XDEADBEEF); +unlike($_, qr/^ $RXhex $/x, "Bad RXhex: $_") + foreach qw(1 x1 0123 0b1010101 -0x12345); + +like($_, qr/^ $RXoct $/x, "Good RXoct: $_") + foreach qw(0 01 07 077 0777 00001 010101 01234567); +unlike($_, qr/^ $RXoct $/x, "Bad RXoct: $_") + foreach qw(1 08 018 0f 0x777 00009 0b1010101); + +like($_, qr/^ $RXuint $/x, "Good RXuint: $_") + foreach qw(0 01 1 9 999 00001 987654321); +unlike($_, qr/^ $RXuint $/x, "Bad RXuint: $_") + foreach qw(-1 0x1 -9 0xf 1.0 1e3 -0x9 0b1010101); + +like($_, qr/^ $RXint $/x, "Good RXint: $_") + foreach qw(0 1 9 -09 999 -90909 00001 010101 123456789); +unlike($_, qr/^ $RXint $/x, "Bad RXint: $_") + foreach qw(0f 0-1 0x777 1.0 1e30 fedcba 0b1010101); + +like($_, qr/^ $RXnum $/x, "Good RXnum: $_") + foreach qw(0 01 0.1 .9 -.9 9.0 -1e2 0.1e+1 .1e1 -.1e1 -1.1E-1 3.1415926535); +unlike($_, qr/^ $RXnum $/x, "Bad RXnum: $_") + foreach qw(0f 0-1 e1 1.e1 1.x -e2 1e3-0 +1 0b1010101); + +# All '\' chars must be doubled inside qr() +like($_, qr/^ $RXdqs $/x, "Good RXdqs: $_") + foreach qw("" "a" "\\"" "\\\\" "\\'" "\\x" "\\\\\\"" "\\"\\\\\\""); +unlike($_, qr/^ $RXdqs $/x, "Bad RXdqs: $_") + foreach qw(x 'x' "x\\" "x\\"x\\"); diff --git a/src/tools/test/Makefile b/src/tools/test/Makefile index 2fed19509..f5fa4fc1a 100644 --- a/src/tools/test/Makefile +++ b/src/tools/test/Makefile @@ -2,12 +2,14 @@ # Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne # National Laboratory. # EPICS BASE is distributed subject to a Software License Agreement found -# in the file LICENSE that is included with this distribution. +# in the file LICENSE that is included with this distribution. #************************************************************************* TOP=../../.. include $(TOP)/configure/CONFIG + +TESTS += Base TESTS += Breaktable TESTS += DBD TESTS += Device @@ -24,4 +26,3 @@ TESTS += Variable TESTSCRIPTS_HOST += $(TESTS:%=%.t) include $(TOP)/configure/RULES -