3c99391d93
In some cases the license-identification header was missing, so I added that as well. Replaced the remaining headers that specifically identified "Versions 3.13.7 and higher". Makefiles and the build system were deliberately excluded.
104 lines
3.1 KiB
Prolog
104 lines
3.1 KiB
Prolog
#!/usr/bin/perl
|
|
######################################################################
|
|
# SPDX-License-Identifier: EPICS
|
|
# EPICS BASE is distributed subject to a Software License Agreement
|
|
# found in file LICENSE that is included with this distribution.
|
|
######################################################################
|
|
|
|
use lib '@TOP@/lib/perl';
|
|
|
|
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\\");
|