143 lines
3.5 KiB
Perl
143 lines
3.5 KiB
Perl
# Common utility functions used by the DBD components
|
|
|
|
package DBD::Base;
|
|
|
|
use Carp;
|
|
require Exporter;
|
|
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved
|
|
&identifier &unquote &escapeCcomment &escapeCstring $RXident $RXname
|
|
$RXuint $RXint $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr);
|
|
|
|
|
|
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 $RXsqs = qr/' (?: [^'] | \\' )* ' /x;
|
|
our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
|
|
|
|
our @context;
|
|
|
|
|
|
sub pushContext {
|
|
my ($ctxt) = @_;
|
|
unshift @context, $ctxt;
|
|
}
|
|
|
|
sub popContext {
|
|
my ($ctxt) = @_;
|
|
my $pop = shift @context;
|
|
($ctxt ne $pop) and
|
|
dieContext("Leaving context \"$ctxt\", found \"$pop\" instead.",
|
|
"\tBraces must be closed in the same file they open in.");
|
|
}
|
|
|
|
sub dieContext {
|
|
my $msg = join "\n\t", @_;
|
|
die "$msg\nContext: ", join(' in ', @context), "\n";
|
|
}
|
|
|
|
sub warnContext {
|
|
my $msg = join "\n\t", @_;
|
|
print STDERR "$msg\nContext: ", join(' in ', @context), "\n";
|
|
}
|
|
|
|
|
|
# Input checking
|
|
|
|
sub unquote (\$) {
|
|
my ($s) = @_;
|
|
$$s =~ s/^"(.*)"$/$1/o;
|
|
return $$s;
|
|
}
|
|
|
|
# Reserved words from C++ and the DB/DBD file parser
|
|
my %reserved = map { $_ => undef } qw(and and_eq asm auto bitand bitor bool
|
|
break case catch char class compl const const_cast continue default delete
|
|
do double dynamic_cast else enum explicit export extern false float for
|
|
friend goto if inline int long mutable namespace new not not_eq operator or
|
|
or_eq private protected public register reinterpret_cast return short signed
|
|
sizeof static static_cast struct switch template this throw true try typedef
|
|
typeid typename union unsigned using virtual void volatile wchar_t while xor
|
|
xor_eq addpath alias breaktable choice device driver field function grecord
|
|
include info menu path record recordtype registrar variable);
|
|
sub is_reserved {
|
|
my $id = shift;
|
|
return exists $reserved{$id};
|
|
}
|
|
|
|
sub identifier {
|
|
my ($id, $what) = @_;
|
|
unquote $id;
|
|
confess "DBD::Base::identifier: $what undefined!"
|
|
unless defined $id;
|
|
$id =~ m/^$RXident$/o 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'",
|
|
"Identifier is a C++ reserved word.")
|
|
if is_reserved($id);
|
|
return $id;
|
|
}
|
|
|
|
|
|
# Output filtering
|
|
|
|
sub escapeCcomment {
|
|
($_) = @_;
|
|
s/\*\//**/g;
|
|
return $_;
|
|
}
|
|
|
|
sub escapeCstring {
|
|
($_) = @_;
|
|
# How to do this?
|
|
return $_;
|
|
}
|
|
|
|
|
|
# Base class routines for the DBD component objects
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $this = {};
|
|
bless $this, $class;
|
|
return $this->init(@_);
|
|
}
|
|
|
|
sub init {
|
|
my ($this, $name, $what) = @_;
|
|
$this->{NAME} = identifier($name, "$what name");
|
|
$this->{WHAT} = $what;
|
|
return $this;
|
|
}
|
|
|
|
sub name {
|
|
return shift->{NAME};
|
|
}
|
|
|
|
sub what {
|
|
return shift->{WHAT};
|
|
}
|
|
|
|
sub add_comment {
|
|
my ($this, $comment) = @_;
|
|
# Ignore
|
|
}
|
|
|
|
sub equals {
|
|
my ($a, $b) = @_;
|
|
return $a->{NAME} eq $b->{NAME}
|
|
&& $a->{WHAT} eq $b->{WHAT};
|
|
}
|
|
|
|
1;
|