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