From fad89189da1a1fd57434dffcbfac8eec0ee2ad56 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 7 Sep 2017 17:38:58 -0500 Subject: [PATCH 1/9] Fix typo in CAref.html --- src/ca/CAref.html | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/ca/CAref.html b/src/ca/CAref.html index 0b9af7b30..13bcd795f 100644 --- a/src/ca/CAref.html +++ b/src/ca/CAref.html @@ -2746,7 +2746,7 @@ time.

USERFUNC
-
Optional address of the user's callback function to be run when the +
Optional pointer to the user's callback function to be run when the connection state changes. Casual users of channel access may decide to set this field to null or 0 if they do not need to have a callback function run in response to each connection state change event. @@ -2921,7 +2921,7 @@ but they do not cause the record to be processed.

PFUNC
-
address of user supplied callback function to be +
Pointer to a user supplied callback function to be run when the requested operation completes
@@ -3029,7 +3029,7 @@ when a CA get request is initiated.

USERFUNC
-
Address of user supplied callback function to be +
Pointer to a user supplied callback function to be run when the requested operation completes.
@@ -3130,8 +3130,8 @@ indicating the current state of the channel.

channel identifier
-
USRERFUNC
-
The address of user supplied callback function to +
USERFUNC
+
Pointer to a user supplied callback function to be invoked with each subscription update.
@@ -3429,7 +3429,7 @@ field should not be used.

Arguments

USERFUNC
-
Address of user callback function to be executed when an exceptions +
Pointer to a user callback function to be executed when exceptions occur. Passing a null value causes the default exception handler to be reinstalled. The following structure is passed by value to the user's callback function. Currently, the op field can be one of @@ -3564,7 +3564,7 @@ default handler uses fprintf to send messages to 'stderr'.

Arguments

PFUNC
-
The address of a user supplied callback handler to be invoked when CA +
A pointer to a user supplied callback handler to be invoked when CA prints diagnostic messages. Installing a null pointer will cause the default callback handler to be reinstalled.
@@ -3612,7 +3612,7 @@ specified channel.

PFUNC
-
Address of user supplied callback function. A null pointer uninstalls +
Pointer to a user supplied callback function. A null pointer uninstalls the current handler. The following arguments are passed by value to the supplied callback handler. 
typedef struct ca_access_rights {

From 13fa1e2722443a67a861fb552a25c05ecd95fec0 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Thu, 7 Sep 2017 17:39:42 -0500
Subject: [PATCH 2/9] Travis: Use 'make test-results' for more compact output

---
 ci/travis-build.sh | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ci/travis-build.sh b/ci/travis-build.sh
index ba752ac4a..a3ca3fd16 100644
--- a/ci/travis-build.sh
+++ b/ci/travis-build.sh
@@ -86,5 +86,5 @@ make -j2 $EXTRA
 if [ "$TEST" != "NO" ]
 then
    make tapfiles
-   find . -name '*.tap' -print0 | xargs -0 -n1 prove -e cat -f
+   make -s test-results
 fi

From cffa2e8f464bde0e63209335cc30ce4ce9b66151 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Tue, 19 Sep 2017 16:38:27 -0500
Subject: [PATCH 3/9] Fix typo in cvtFast.c

Probably only affects MEDM
---
 src/libCom/cvtFast/cvtFast.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/libCom/cvtFast/cvtFast.c b/src/libCom/cvtFast/cvtFast.c
index 4e04b4515..106c1ba47 100644
--- a/src/libCom/cvtFast/cvtFast.c
+++ b/src/libCom/cvtFast/cvtFast.c
@@ -457,7 +457,7 @@ size_t
 }
 
 size_t
-    cvtInt32OctalString(epicsInt32 val, char *pdest)
+    cvtInt32ToOctalString(epicsInt32 val, char *pdest)
 {
     if (val == 0) {
         *pdest++ = '0';

From c441cdd5a43ce0b096f29b47bd62765ae2ab735d Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Mon, 25 Sep 2017 12:14:48 -0500
Subject: [PATCH 4/9] Adjust comments about EPICS_TIMEZONE

---
 configure/CONFIG_SITE_ENV | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/configure/CONFIG_SITE_ENV b/configure/CONFIG_SITE_ENV
index 271fd7134..1decb05c8 100644
--- a/configure/CONFIG_SITE_ENV
+++ b/configure/CONFIG_SITE_ENV
@@ -27,8 +27,9 @@
 # Time service:
 # EPICS_TIMEZONE
 #	Local timezone info for vxWorks and RTEMS.  The format is
-#	    ::::
-#	where the start and end are mmddhh - that is month,day,hour
+#	    ::::
+#	where  is only used by strftime() for %Z conversions,
+#	and  and  are mmddhh - that is month,day,hour
 #	e.g. for ANL in 2018: EPICS_TIMEZONE=CUS::360:031102:110402
 #	The future dates below assume the rules don't get changed;
 #	see http://www.timeanddate.com/time/dst/2018.html to check.

From 22debb3532606888ef5f8066e370f5a719df6b56 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Mon, 25 Sep 2017 15:41:31 -0500
Subject: [PATCH 5/9] Fix for LP: #1702298

---
 src/cas/build/Makefile | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/src/cas/build/Makefile b/src/cas/build/Makefile
index ab4a14d99..f1ee7b81e 100644
--- a/src/cas/build/Makefile
+++ b/src/cas/build/Makefile
@@ -74,10 +74,9 @@ LIBSRCS += casStreamIO.cc
 LIBSRCS += ipIgnoreEntry.cc
 
 # There is a bug in some vxWorks compilers that these work around:
-ifeq ($(VX_GNU_VERSION), 4.1.2)
-  casStreamOS_CXXFLAGS_vxWorks-ppc604_altivec = -O0
-  casStreamOS_CXXFLAGS_vxWorks-ppc604_long = -O0
-  casStreamOS_CXXFLAGS_vxWorks-ppc604 = -O0
+ifeq ($(VXWORKS_VERSION)$(filter -mcpu=604,$(ARCH_DEP_CFLAGS)), 6.6-mcpu=604)
+  casDGIntfOS_CXXFLAGS = -fno-inline
+  casStreamOS_CXXFLAGS = -fno-inline
 endif
 
 LIBSRCS_vxWorks += templateInstances.cpp

From 32a6f6c4f1672d4c7b3a7008de89b9ed4eb97a04 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Mon, 9 Oct 2017 14:45:01 +0200
Subject: [PATCH 6/9] Fix DBD parsing slow-up with Perl 5.20 and later

---
 src/tools/DBD/Parser.pm | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/src/tools/DBD/Parser.pm b/src/tools/DBD/Parser.pm
index 901420685..113ef42a8 100644
--- a/src/tools/DBD/Parser.pm
+++ b/src/tools/DBD/Parser.pm
@@ -78,8 +78,13 @@ sub parseCommon {
         m/\G \s* /oxgc;
 
         # Extract POD
-        if (m/\G ( = [a-zA-Z] .* ) \n/oxgc) {
-            $obj->add_pod($1, &parsePod);
+        if (m/\G ( = [a-zA-Z] )/xgc) {
+	    # The above regex was split from the one below for performance.
+	    # Using m/\G ( = [a-zA-Z] .* ) \n/ is slow in Perl 5.20 and later.
+	    my $directive = $1;
+	    m/\G ( .* ) \n/xgc;
+	    $directive .= $1;
+            $obj->add_pod($directive, &parsePod);
         }
         elsif (m/\G \# /oxgc) {
             if (m/\G \# ! BEGIN \{ ( [^}]* ) \} ! \# \# \n/oxgc) {

From 3011ac21439500d56d768a85147afb1be48b5cf2 Mon Sep 17 00:00:00 2001
From: Ralph Lange 
Date: Tue, 10 Oct 2017 11:49:46 +0200
Subject: [PATCH 7/9] ioc/misc: remove double inclusion of dbBase.h in
 iocInit.c

---
 src/ioc/misc/iocInit.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/ioc/misc/iocInit.c b/src/ioc/misc/iocInit.c
index 98f7dae11..647157d44 100644
--- a/src/ioc/misc/iocInit.c
+++ b/src/ioc/misc/iocInit.c
@@ -22,7 +22,6 @@
 #include 
 #include 
 
-#include "dbBase.h"
 #include "dbDefs.h"
 #include "ellLib.h"
 #include "envDefs.h"

From 7a0b095fd36bc7a3f491a8ece619579598401387 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Thu, 19 Oct 2017 23:14:12 -0500
Subject: [PATCH 8/9] Remove /o flags from Perl regex's

Apparently they don't help in modern Perls, and can cause problems.
This commit also replaces \d with [0-9], \d also matches foreign digits.
---
 src/tools/DBD/Base.pm       | 14 ++++----
 src/tools/DBD/Device.pm     | 22 ++++++------
 src/tools/DBD/Output.pm     |  2 +-
 src/tools/DBD/Parser.pm     | 70 ++++++++++++++++++-------------------
 src/tools/DBD/Recfield.pm   |  2 +-
 src/tools/DBD/Record.pm     |  2 +-
 src/tools/EPICS/Readfile.pm | 14 ++++----
 7 files changed, 63 insertions(+), 63 deletions(-)

diff --git a/src/tools/DBD/Base.pm b/src/tools/DBD/Base.pm
index 0751c68fd..f840f6e54 100644
--- a/src/tools/DBD/Base.pm
+++ b/src/tools/DBD/Base.pm
@@ -19,13 +19,13 @@ our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x;
 our $RXname =  qr/ [a-zA-Z0-9_\-:.\[\]<>;]+ /x;
 our $RXhex =   qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
 our $RXoct =   qr/ 0 [0-7]* /x;
-our $RXuint =  qr/ \d+ /x;
-our $RXint =   qr/ -? $RXuint /ox;
-our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /ox;
-our $RXintx =  qr/ ( $RXhex | $RXoct | $RXint ) /ox;
-our $RXnum =   qr/ -? (?: \d+ | \d* \. \d+ ) (?: [eE] [-+]? \d+ )? /x;
 our $RXdqs =   qr/ " (?: [^"] | \\" )* " /x;
-our $RXstr =   qr/ ( $RXname | $RXnum | $RXdqs ) /ox;
+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 $RXstr =   qr/ ( $RXname | $RXnum | $RXdqs ) /x;
 
 our @context;
 
@@ -73,7 +73,7 @@ sub identifier {
     my ($this, $id, $what) = @_;
     confess "DBD::Base::identifier: $what undefined!"
         unless defined $id;
-    $id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'",
+    $id =~ m/^$RXident$/ or dieContext("Illegal $what '$id'",
         "Identifiers are used in C code so must start with a letter, followed",
         "by letters, digits and/or underscore characters only.");
     dieContext("Illegal $what '$id'",
diff --git a/src/tools/DBD/Device.pm b/src/tools/DBD/Device.pm
index 2fa1777d9..1e6d0684c 100644
--- a/src/tools/DBD/Device.pm
+++ b/src/tools/DBD/Device.pm
@@ -3,17 +3,17 @@ use DBD::Base;
 @ISA = qw(DBD::Base);
 
 my %link_types = (
-    CONSTANT  => qr/$RXnum/o,
-    PV_LINK   => qr/$RXname \s+ [.NPCAMS ]*/ox,
-    JSON_LINK => qr/\{ .* \}/ox,
-    VME_IO    => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/ox,
-    CAMAC_IO  => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/ox,
-    RF_IO     => qr/\# (?: \s* [RMDE] \s* $RXintx)*/ox,
-    AB_IO     => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/ox,
-    GPIB_IO   => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/ox,
-    BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/ox,
-    BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/ox,
-    VXI_IO    => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/ox,
+    CONSTANT  => qr/$RXnum/,
+    PV_LINK   => qr/$RXname \s+ [.NPCAMS ]*/x,
+    JSON_LINK => qr/\{ .* \}/x,
+    VME_IO    => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/x,
+    CAMAC_IO  => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/x,
+    RF_IO     => qr/\# (?: \s* [RMDE] \s* $RXintx)*/x,
+    AB_IO     => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/x,
+    GPIB_IO   => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/x,
+    BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/x,
+    BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/x,
+    VXI_IO    => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/x,
     INST_IO   => qr/@.*/
 );
 
diff --git a/src/tools/DBD/Output.pm b/src/tools/DBD/Output.pm
index c3bce9e58..55051dfb3 100644
--- a/src/tools/DBD/Output.pm
+++ b/src/tools/DBD/Output.pm
@@ -60,7 +60,7 @@ sub OutputRecordtypes {
                 $field->name, $field->dbf_type;
             while (my ($attr, $val) = each %{$field->attributes}) {
                 $val = "\"$val\""
-                    if $val !~ m/^$RXname$/ox
+                    if $val !~ m/^$RXname$/x
                        || $attr eq 'prompt'
                        || $attr eq 'initial';
                 printf $out "        %s(%s)\n", $attr, $val;
diff --git a/src/tools/DBD/Parser.pm b/src/tools/DBD/Parser.pm
index a3e1971fd..6065486c8 100644
--- a/src/tools/DBD/Parser.pm
+++ b/src/tools/DBD/Parser.pm
@@ -28,47 +28,47 @@ sub ParseDBD {
     (my $dbd, $_) = @_;
     while (1) {
         parseCommon($dbd);
-        if (m/\G menu \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
+        if (m/\G menu \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
             print "Menu: $1\n" if $debug;
             my ($menu_name) = unquote($1);
             parse_menu($dbd, $menu_name);
         }
-        elsif (m/\G driver \s* \( \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G driver \s* \( \s* $RXstr \s* \)/xgc) {
             print "Driver: $1\n" if $debug;
             my ($driver_name) = unquote($1);
             $dbd->add(DBD::Driver->new($driver_name));
         }
-        elsif (m/\G link \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G link \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/xgc) {
             print "Link $1, $2\n" if $debug;
             my ($key, $lset) = unquote($1, $2);
             $dbd->add(DBD::Link->new($key, $lset));
         }
-        elsif (m/\G registrar \s* \( \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G registrar \s* \( \s* $RXstr \s* \)/xgc) {
             print "Registrar: $1\n" if $debug;
             my ($registrar_name) = unquote($1);
             $dbd->add(DBD::Registrar->new($registrar_name));
         }
-        elsif (m/\G function \s* \( \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G function \s* \( \s* $RXstr \s* \)/xgc) {
             print "Function: $1\n" if $debug;
             my ($function_name) = unquote($1);
             $dbd->add(DBD::Function->new($function_name));
         }
-        elsif (m/\G breaktable \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
+        elsif (m/\G breaktable \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
             print "Breaktable: $1\n" if $debug;
             my ($breaktable_name) = unquote($1);
             parse_breaktable($dbd, $breaktable_name);
         }
-        elsif (m/\G recordtype \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
+        elsif (m/\G recordtype \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
             print "Recordtype: $1\n" if $debug;
             my ($recordtype_name) = unquote($1);
             parse_recordtype($dbd, $recordtype_name);
         }
-        elsif (m/\G g?record \s* \( \s* $RXstr \s*, \s* $RXstr \s* \) \s* \{/oxgc) {
+        elsif (m/\G g?record \s* \( \s* $RXstr \s*, \s* $RXstr \s* \) \s* \{/xgc) {
             print "Record: $1, $2\n" if $debug;
             my ($record_type, $record_name) = unquote($1, $2);
             parse_record($dbd, $record_type, $record_name);
         }
-        elsif (m/\G alias \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G alias \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/xgc) {
             print "Alias: $1, $2\n" if $debug;
             my ($record_name, $alias) = unquote($1, $2);
             my $rec = $dbd->record($record_name);
@@ -79,18 +79,18 @@ sub ParseDBD {
             $rec->add_alias($alias);
             $dbd->add($rec, $alias);
         }
-        elsif (m/\G variable \s* \( \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G variable \s* \( \s* $RXstr \s* \)/xgc) {
             print "Variable: $1\n" if $debug;
             my ($variable_name) = unquote($1);
             $dbd->add(DBD::Variable->new($variable_name));
         }
-        elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
             print "Variable: $1, $2\n" if $debug;
             my ($variable_name, $variable_type) = unquote($1, $2);
             $dbd->add(DBD::Variable->new($variable_name, $variable_type));
         }
         elsif (m/\G device \s* \( \s* $RXstr \s* , \s* $RXstr \s* ,
-                          \s* $RXstr \s* , \s*$RXstr \s* \)/oxgc) {
+                          \s* $RXstr \s* , \s*$RXstr \s* \)/xgc) {
             print "Device: $1, $2, $3, $4\n" if $debug;
             my ($record_type, $link_type, $dset, $choice) =
                 unquote($1, $2, $3, $4);
@@ -112,7 +112,7 @@ sub parseCommon {
     my ($obj) = @_;
     while (1) {
         # Skip leading whitespace
-        m/\G \s* /oxgc;
+        m/\G \s* /xgc;
 
         # Extract POD
         if (m/\G ( = [a-zA-Z] )/xgc) {
@@ -123,17 +123,17 @@ sub parseCommon {
 	    $directive .= $1;
             $obj->add_pod($directive, parsePod());
         }
-        elsif (m/\G \# /oxgc) {
-            if (m/\G \# ! BEGIN \{ ( [^}]* ) \} ! \# \# \n/oxgc) {
+        elsif (m/\G \# /xgc) {
+            if (m/\G \# ! BEGIN \{ ( [^}]* ) \} ! \# \# \n/xgc) {
                 print "File-Begin: $1\n" if $debug;
                 pushContext("file '$1'");
             }
-            elsif (m/\G \# ! END \{ ( [^}]* ) \} ! \# \# \n?/oxgc) {
+            elsif (m/\G \# ! END \{ ( [^}]* ) \} ! \# \# \n?/xgc) {
                 print "File-End: $1\n" if $debug;
                 popContext("file '$1'");
             }
             else {
-                m/\G (.*) \n/oxgc;
+                m/\G (.*) \n/xgc;
                 $obj->add_comment($1);
                 print "Comment: $1\n" if $debug;
             }
@@ -144,21 +144,21 @@ sub parseCommon {
 }
 
 sub unquote {
-    return map { m/^ ("?) (.*) \1 $/ox; $2 } @_;
+    return map { m/^ ("?) (.*) \1 $/x; $2 } @_;
 }
 
 sub parsePod {
     pushContext("Pod markup");
     my @pod;
     while (1) {
-        if (m/\G ( =cut .* ) \n?/oxgc) {
+        if (m/\G ( =cut .* ) \n?/xgc) {
             popContext("Pod markup");
             return @pod;
         }
-        elsif (m/\G ( .* ) $/oxgc) {
+        elsif (m/\G ( .* ) $/xgc) {
             dieContext("Unexpected end of input file, Pod block not closed");
         }
-        elsif (m/\G ( .* ) \n/oxgc) {
+        elsif (m/\G ( .* ) \n/xgc) {
             push @pod, $1
         }
     }
@@ -170,12 +170,12 @@ sub parse_menu {
     my $menu = DBD::Menu->new($menu_name);
     while(1) {
         parseCommon($menu);
-        if (m/\G choice \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
+        if (m/\G choice \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
             print " Menu-Choice: $1, $2\n" if $debug;
             my ($choice_name, $value) = unquote($1, $2);
             $menu->add_choice($choice_name, $value);
         }
-        elsif (m/\G \}/oxgc) {
+        elsif (m/\G \}/xgc) {
             print " Menu-End:\n" if $debug;
             $dbd->add($menu);
             popContext("menu($menu_name)");
@@ -193,17 +193,17 @@ sub parse_breaktable {
     my $bt = DBD::Breaktable->new($breaktable_name);
     while(1) {
         parseCommon($bt);
-        if (m/\G point\s* \(\s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
+        if (m/\G point\s* \(\s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
             print " Breaktable-Point: $1, $2\n" if $debug;
             my ($raw, $eng) = unquote($1, $2);
             $bt->add_point($raw, $eng);
         }
-        elsif (m/\G $RXstr \s* (?: , \s*)? $RXstr (?: \s* ,)?/oxgc) {
+        elsif (m/\G $RXstr \s* (?: , \s*)? $RXstr (?: \s* ,)?/xgc) {
             print " Breaktable-Data: $1, $2\n" if $debug;
             my ($raw, $eng) = unquote($1, $2);
             $bt->add_point($raw, $eng);
         }
-        elsif (m/\G \}/oxgc) {
+        elsif (m/\G \}/xgc) {
             print " Breaktable-End:\n" if $debug;
             $dbd->add($bt);
             popContext("breaktable($breaktable_name)");
@@ -221,16 +221,16 @@ sub parse_recordtype {
     my $rtyp = DBD::Recordtype->new($record_type);
     while(1) {
         parseCommon($rtyp);
-        if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \) \s* \{/oxgc) {
+        if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \) \s* \{/xgc) {
             print " Recordtype-Field: $1, $2\n" if $debug;
             my ($field_name, $field_type) = unquote($1, $2);
             parse_field($rtyp, $field_name, $field_type);
         }
-        elsif (m/\G % (.*) \n/oxgc) {
+        elsif (m/\G % (.*) \n/xgc) {
             print " Recordtype-Cdef: $1\n" if $debug;
             $rtyp->add_cdef($1);
         }
-        elsif (m/\G \}/oxgc) {
+        elsif (m/\G \}/xgc) {
             print " Recordtype-End:\n" if $debug;
             $dbd->add($rtyp);
             popContext("recordtype($record_type)");
@@ -262,17 +262,17 @@ sub parse_record {
     }
     while (1) {
         parseCommon($rec);
-        if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
+        if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
             print " Record-Field: $1, $2\n" if $debug;
             my ($field_name, $value) = unquote($1, $2);
             $rec->put_field($field_name, $value);
         }
-        elsif (m/\G info \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G info \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
             print " Record-Info: $1, $2\n" if $debug;
             my ($info_name, $value) = unquote($1, $2);
             $rec->add_info($info_name, $value);
         }
-        elsif (m/\G alias \s* \( \s* $RXstr \s* \)/oxgc) {
+        elsif (m/\G alias \s* \( \s* $RXstr \s* \)/xgc) {
             print " Record-Alias: $1\n" if $debug;
             my ($alias) = unquote($1);
             dieContext("Can't create alias '$alias', name in use")
@@ -280,7 +280,7 @@ sub parse_record {
             $rec->add_alias($alias);
             $dbd->add($rec, $alias);
         }
-        elsif (m/\G \}/oxgc) {
+        elsif (m/\G \}/xgc) {
             print " Record-End:\n" if $debug;
             $dbd->add($rec);
             popContext("record($record_type, $record_name)");
@@ -298,12 +298,12 @@ sub parse_field {
     pushContext("field($field_name, $field_type)");
     while(1) {
         parseCommon($fld);
-        if (m/\G (\w+) \s* \( \s* $RXstr \s* \)/oxgc) {
+        if (m/\G (\w+) \s* \( \s* $RXstr \s* \)/xgc) {
             print "  Field-Attribute: $1, $2\n" if $debug;
             my ($attr, $value) = unquote($1, $2);
             $fld->add_attribute($attr, $value);
         }
-        elsif (m/\G \}/oxgc) {
+        elsif (m/\G \}/xgc) {
             print "  Field-End:\n" if $debug;
             $rtyp->add_field($fld);
             popContext("field($field_name, $field_type)");
diff --git a/src/tools/DBD/Recfield.pm b/src/tools/DBD/Recfield.pm
index 89beb7be7..f7bfbae46 100644
--- a/src/tools/DBD/Recfield.pm
+++ b/src/tools/DBD/Recfield.pm
@@ -37,7 +37,7 @@ our %field_attrs = (
     base        => qr/^(?:DECIMAL|HEX)$/,
     size        => qr/^\d+$/,
     extra       => qr/^.*$/,
-    menu        => qr/^$RXident$/o,
+    menu        => qr/^$RXident$/,
     prop        => qr/^(?:YES|NO)$/
 );
 
diff --git a/src/tools/DBD/Record.pm b/src/tools/DBD/Record.pm
index 1b7980c2d..e232e2a0b 100644
--- a/src/tools/DBD/Record.pm
+++ b/src/tools/DBD/Record.pm
@@ -36,7 +36,7 @@ sub identifier {
     if ($macrosOk) {
         # FIXME - Check name with macro
     }
-    elsif ($id !~ m/^$RXname$/o) {
+    elsif ($id !~ m/^$RXname$/) {
         my @message;
         push @message, "A $what should contain only letters, digits and these",
             "special characters: _ - : . [ ] < > ;" unless $warned++;
diff --git a/src/tools/EPICS/Readfile.pm b/src/tools/EPICS/Readfile.pm
index 4358a6ad2..c73f1925a 100644
--- a/src/tools/EPICS/Readfile.pm
+++ b/src/tools/EPICS/Readfile.pm
@@ -79,13 +79,13 @@ sub splitPath {
     return @path;
 }
 
-my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
-my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
-my $string = qr/ ( $RXnam | $RXstr ) /ox;
+my $RXstr = qr/ " (?: [^"] | \\" )* "/x;
+my $RXnam = qr/ [a-zA-Z0-9_\-:.[\]<>;]+ /x;
+my $string = qr/ ( $RXnam | $RXstr ) /x;
 
 sub unquote {
     my ($s) = @_;
-    $s =~ s/^"(.*)"$/$1/o;
+    $s =~ s/^"(.*)"$/$1/;
     return $s;
 }
 
@@ -147,17 +147,17 @@ sub Readfile {
     my @input = split /\n/, $input;
     my @output;
     foreach (@input) {
-        if (m/^ \s* include \s+ $string /ox) {
+        if (m/^ \s* include \s+ $string /x) {
             $arg = unquote($1);
             print " include $arg\n" if $debug;
             push @output, "##! include \"$arg\"";
             push @output, Readfile($arg, $macros, $Rpath);
-        } elsif (m/^ \s* addpath \s+ $string /ox) {
+        } elsif (m/^ \s* addpath \s+ $string /x) {
             $arg = unquote($1);
             print " addpath $arg\n" if $debug;
             push @output, "##! addpath \"$arg\"";
             push @{$Rpath}, splitPath($arg);
-        } elsif (m/^ \s* path \s+ $string /ox) {
+        } elsif (m/^ \s* path \s+ $string /x) {
             $arg = unquote($1);
             print " path $arg\n" if $debug;
             push @output, "##! path \"$arg\"";

From d5a3df506c317b12acaa7dec353e07c19c047665 Mon Sep 17 00:00:00 2001
From: Andrew Johnson 
Date: Thu, 19 Oct 2017 23:19:27 -0500
Subject: [PATCH 9/9] 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   |  7 +--
 src/tools/test/Base.plt | 98 +++++++++++++++++++++++++++++++++++++++++
 src/tools/test/Makefile |  5 ++-
 3 files changed, 105 insertions(+), 5 deletions(-)
 create mode 100644 src/tools/test/Base.plt

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
-