Fix regex's, add tests for DBD::Base

Changed $RXname to accept {} chars in the middle of a PV name.
RXdqs now handles escaped double-quotes and back-slashes properly.
New test program for the DBD::Base class and checks for each of
the $RXxxx variable regex's.

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 $_;
 }
 

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\\");

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
-