epics/epics-base
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

Merged compiled-dbd branch.

Browse Source 
This does all DBD-file processing at build-time in Perl scripts.
The result should behave almost identically to the old programs.
This commit is contained in:
Andrew Johnson
2012-04-04 12:07:46 -05:00
parent 2ae1105ecc 9ec0cff0e5
commit de6d7b2cf0
44 changed files with 2962 additions and 826 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
configure/CONFIG_BASE
View File

@@ -57,11 +57,11 @@ TOOLS = $(EPICS_BASE_HOST_BIN)
# Epics base build tools and tool flags
MAKEBPT = $(call PATH_FILTER, $(TOOLS)/makeBpt$(HOSTEXE))
DBEXPAND = $(call PATH_FILTER, $(TOOLS)/dbExpand$(HOSTEXE))
DBTORECORDTYPEH = $(call PATH_FILTER, $(TOOLS)/dbToRecordtypeH$(HOSTEXE))
DBTOMENUH = $(call PATH_FILTER, $(TOOLS)/dbToMenuH$(HOSTEXE))
DBEXPAND = $(PERL) $(TOOLS)/dbdExpand.pl
DBTORECORDTYPEH = $(PERL) $(TOOLS)/dbdToRecordtypeH.pl
DBTOMENUH = $(PERL) $(TOOLS)/dbdToMenuH.pl
REGISTERRECORDDEVICEDRIVER = $(PERL) $(TOOLS)/registerRecordDeviceDriver.pl
CONVERTRELEASE=$(PERL) $(TOOLS)/convertRelease.pl
CONVERTRELEASE = $(PERL) $(TOOLS)/convertRelease.pl
#-------------------------------------------------------
# tools for installing libraries and products

43
configure/RULES.Db
View File

@@ -112,9 +112,6 @@ DBDDEPENDS_FILES += $(addsuffix $(DEP),$(HINC) \
$(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBS)) \
$(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBDS)))
DBDDEPENDS_FLAGS = $(subst -I,,$(filter-out -S%,$(DBDFLAGS)))
DBDDEPENDS_CMD = -$(MKMF) -m $(notdir $@)$(DEP) $(DBDDEPENDS_FLAGS) $@ $<
MAKEDBDEPENDS = $(PERL) $(TOOLS)/makeDbDepends.pl
#####################################################
@@ -226,34 +223,34 @@ $(INSTALL_DB)/%.template: %.template
$(COMMON_DIR)/%Record.h: $(COMMON_DIR)/%Record.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
@$(RM) $(notdir $@)
$(DBTORECORDTYPEH) $(DBDFLAGS) $< $(notdir $@)
$(DBTORECORDTYPEH) $(DBDFLAGS) -o $(notdir $@) $<
@$(MV) $(notdir $@) $@
$(COMMON_DIR)/%Record.h: %Record.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
@$(RM) $(notdir $@)
$(DBTORECORDTYPEH) $(DBDFLAGS) $< $(notdir $@)
$(DBTORECORDTYPEH) $(DBDFLAGS) -o $(notdir $@) $<
@$(MV) $(notdir $@) $@
$(COMMON_DIR)/menu%.h: $(COMMON_DIR)/menu%.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
@$(RM) $(notdir $@)
$(DBTOMENUH) $(DBDFLAGS) $< $(notdir $@)
$(DBTOMENUH) $(DBDFLAGS) -o $(notdir $@) $<
@$(MV) $(notdir $@) $@
$(COMMON_DIR)/menu%.h: menu%.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
@$(RM) $(notdir $@)
$(DBTOMENUH) $(DBDFLAGS) $< $(notdir $@)
$(DBTOMENUH) $(DBDFLAGS) -o $(notdir $@) $<
@$(MV) $(notdir $@) $@
.PRECIOUS: $(COMMON_DIR)/%.h
@@ -264,10 +261,10 @@ $(COMMON_DIR)/bpt%.dbd: bpt%.data
$(MAKEBPT) $< $(notdir $@)
@$(MV) $(notdir $@) $@
$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd
$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
$(ECHO) "Expanding dbd"
@$(RM) $(notdir $@)
@$(DBEXPAND) $(DBDFLAGS) -o $(notdir $@) $<
@@ -275,8 +272,8 @@ $(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd
$(COMMON_DIR)/%.dbd: %Include.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBDDEPENDS_CMD)
echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
@$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
@echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
$(ECHO) "Expanding dbd"
@$(RM) $(notdir $@)
$(DBEXPAND) $(DBDFLAGS) -o $(notdir $@) $<
@@ -313,8 +310,8 @@ $(COMMON_DIR)/%.db$(RAW): $(COMMON_DIR)/%.edf
$(COMMON_DIR)/%.db$(RAW): %.substitutions
@$(RM) $(notdir $@)$(DEP)
@$(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) >> $(notdir $@)$(DEP)
echo "$@ : $(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP)
$(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) > $(notdir $@)$(DEP)
@echo "$@: $(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP)
$(ECHO) "Inflating database from $< $(TEMPLATE_FILENAME)"
@$(RM) $@ $*.tmp
$(MSI) $(DBFLAGS) -S$< $(TEMPLATE_FILENAME) > $*.tmp
@@ -322,7 +319,7 @@ $(COMMON_DIR)/%.db$(RAW): %.substitutions
$(COMMON_DIR)/%.db$(RAW): %.template
@$(RM) $(notdir $@)$(DEP)
@$(MAKEDBDEPENDS) $@ $^ >> $(notdir $@)$(DEP)
@$(MAKEDBDEPENDS) $@ $< > $(notdir $@)$(DEP)
$(ECHO) "Inflating database from $<"
@$(RM) $@ $*.tmp
$(MSI) $(DBFLAGS) $< > $*.tmp

3
src/Makefile
View File

@@ -15,6 +15,9 @@ include $(TOP)/configure/CONFIG
DIRS += tools
DIRS += tools/test
tools/test_DEPEND_DIRS = tools
DIRS += template/base
template/base_DEPEND_DIRS = tools

20
src/ioc/db/RULES
View File

@@ -1,5 +1,5 @@
#*************************************************************************
# Copyright (c) 2011 UChicago Argonne LLC, as Operator of Argonne
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# Copyright (c) 2010 Brookhaven Science Associates, as Operator of
# Brookhaven National Lab.
@@ -11,21 +11,11 @@
# This is a Makefile fragment, see src/ioc/Makefile.
menuGlobal.dbd$(DEP): $(DBEXPAND)
# $(filter-out $(STATIC_SRCS),$(dbCore_SRCS)) : $(COMMON_DIR)/dbCommon.h
dbCommon.h$(DEP): $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd
@$(RM) $@
@$(MKMF) -m $@ ../db $(COMMON_DIR)/dbCommon.h $<
$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd
$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd
@$(RM) $(notdir $@)$(DEP)
@$(DBTORECORDTYPEH) -D -I ../db -o $@ $< > $(notdir $@)$(DEP)
@$(RM) $(notdir $@)
$(DBTORECORDTYPEH) -I ../db $< $(notdir $@)
$(DBTORECORDTYPEH) -I ../db -o $(notdir $@) $<
@$(MV) $(notdir $@) $@
$(COMMON_DIR)/dbCommon.h: $(DBTORECORDTYPEH)
$(patsubst %,$(COMMON_DIR)/%.h,$(DBDINC) menuConvert menuGlobal) : \
$(COMMON_DIR)/%.h : $(DBTOMENUH)

20
src/ioc/db/dbCommon.dbd
View File

@@ -82,14 +82,14 @@
prompt("Monitor lock")
special(SPC_NOMOD)
interest(4)
extra("epicsMutexId mlok")
extra("epicsMutexId mlok")
}
%#include "ellLib.h"
field(MLIS,DBF_NOACCESS) {
prompt("Monitor List")
special(SPC_NOMOD)
interest(4)
extra("ELLLIST mlis")
extra("ELLLIST mlis")
}
field(DISP,DBF_UCHAR) {
prompt("Disable putField")
@@ -167,13 +167,13 @@
prompt("Access Security Pvt")
special(SPC_NOMOD)
interest(4)
extra("struct asgMember *asp")
extra("struct asgMember *asp")
}
field(PPN,DBF_NOACCESS) {
prompt("addr of PUTNOTIFY")
special(SPC_NOMOD)
interest(4)
extra("struct putNotify *ppn")
extra("struct putNotify *ppn")
}
field(PPNR,DBF_NOACCESS) {
prompt("pputNotifyRecord")
@@ -191,19 +191,19 @@
prompt("Address of RSET")
special(SPC_NOMOD)
interest(4)
extra("struct rset *rset")
extra("struct rset *rset")
}
field(DSET,DBF_NOACCESS) {
prompt("DSET address")
special(SPC_NOMOD)
interest(4)
extra("struct dset *dset")
extra("struct dset *dset")
}
field(DPVT,DBF_NOACCESS) {
prompt("Device Private")
special(SPC_NOMOD)
interest(4)
extra("void *dpvt")
extra("void *dpvt")
}
field(RDES,DBF_NOACCESS) {
prompt("Address of dbRecordType")
@@ -215,7 +215,7 @@
prompt("Lock Set")
special(SPC_NOMOD)
interest(4)
extra("struct lockRecord *lset")
extra("struct lockRecord *lset")
}
field(PRIO,DBF_MENU) {
prompt("Scheduling Priority")
@@ -231,7 +231,7 @@
prompt("Break Point")
special(SPC_NOMOD)
interest(1)
extra("char bkpt")
extra("char bkpt")
}
field(UDF,DBF_UCHAR) {
prompt("Undefined")
@@ -245,7 +245,7 @@
prompt("Time")
special(SPC_NOMOD)
interest(2)
extra("epicsTimeStamp time")
extra("epicsTimeStamp time")
}
field(FLNK,DBF_FWDLINK) {
prompt("Forward Process Link")

18
src/ioc/dbStatic/Makefile
View File

@@ -32,26 +32,10 @@ dbCore_SRCS += dbStaticRun.c
dbCore_SRCS += dbStaticIocRegister.c
dbStaticHost_SRCS += $(STATIC_SRCS)
dbStaticHost_SRCS += dbStaticNoRun.c
dbStaticHost_SRCS += dbStaticNoRun.c
LIBRARY_HOST += dbStaticHost
dbStaticHost_LIBS = Com
PROD_HOST += dbReadTest dbExpand dbToMenuH dbToRecordtypeH
dbReadTest_SRCS = dbReadTest.c
dbExpand_SRCS = dbExpand.c
dbToMenuH_SRCS = dbToMenuH.c
dbToRecordtypeH_SRCS = dbToRecordtypeH.c
# Include dbStaticHost objects directly in executables
# because of a Circular dependency induced by a rule
# $(INSTALL_LIBS): $(INSTALL_SHRLIBS)
# in RULES_BUILD
dbReadTest_SRCS += $(dbStaticHost_SRCS)
dbExpand_SRCS += $(dbStaticHost_SRCS)
dbToMenuH_SRCS += $(dbStaticHost_SRCS)
dbToRecordtypeH_SRCS += $(dbStaticHost_SRCS)
CLEANS += dbLex.c dbYacc.c

127
src/ioc/dbStatic/dbExpand.c
View File

@@ -1,127 +0,0 @@
/*************************************************************************\
* Copyright (c) 2011 UChicago Argonne LLC, as Operator of Argonne
* National Laboratory.
* Copyright (c) 2002 The Regents of the University of California, as
* Operator of Los Alamos National Laboratory.
* EPICS BASE is distributed subject to a Software License Agreement found
* in file LICENSE that is included with this distribution.
\*************************************************************************/
/* dbExpand.c */
/* Author: Marty Kraimer Date: 30NOV95 */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include "dbDefs.h"
#include "epicsPrint.h"
#include "errMdef.h"
#include "dbStaticLib.h"
#include "dbStaticPvt.h"
#include "dbBase.h"
#include "gpHash.h"
#include "osiFileName.h"
DBBASE *pdbbase = NULL;
void usage(void)
{
fprintf(stderr, "Usage:\n\tdbExpand -b -Ipath -ooutfile "
"-S macro=value file1.dbd file2.dbd ...\n");
fprintf(stderr,"Specifying any path will replace the default of '.'\n");
fprintf(stderr,"The -b option enables relaxed breakpoint table checking\n");
}
int main(int argc,char **argv)
{
char *path = NULL;
char *sub = NULL;
int pathLength = 0;
int subLength = 0;
char *outFilename = NULL;
FILE *outFP = stdout;
long status;
long returnStatus = 0;
static char *pathSep = OSI_PATH_LIST_SEPARATOR;
static char *subSep = ",";
/* Discard program name argv[0] */
++argv;
--argc;
while ((argc > 1) && (**argv == '-')) {
char optLtr = (*argv)[1];
char *optArg;
if (strlen(*argv) > 2 || optLtr == 'b') {
optArg = *argv+2;
++argv;
--argc;
} else {
optArg = argv[1];
argv += 2;
argc -= 2;
}
switch (optLtr) {
case 'o':
outFilename = optArg;
break;
case 'I':
dbCatString(&path, &pathLength, optArg, pathSep);
break;
case 'S':
dbCatString(&sub, &subLength, optArg, subSep);
break;
case 'b':
dbBptNotMonotonic = 1;
break;
default:
fprintf(stderr, "dbExpand: Unknown option '-%c'\n", optLtr);
usage();
exit(1);
}
}
if (argc < 1) {
fprintf(stderr, "dbExpand: No input file specified\n");
usage();
exit(1);
}
for (; argc>0; --argc, ++argv) {
status = dbReadDatabase(&pdbbase,*argv,path,sub);
if (status) returnStatus = status;
}
if (returnStatus) {
errlogFlush();
fprintf(stderr, "dbExpand: Input errors, no output generated\n");
exit(1);
}
if (outFilename) {
outFP = fopen(outFilename, "w");
if (!outFP) {
perror("dbExpand");
exit(1);
}
}
dbWriteMenuFP(pdbbase,outFP,0);
dbWriteRecordTypeFP(pdbbase,outFP,0);
dbWriteDeviceFP(pdbbase,outFP);
dbWriteDriverFP(pdbbase,outFP);
dbWriteRegistrarFP(pdbbase,outFP);
dbWriteFunctionFP(pdbbase,outFP);
dbWriteVariableFP(pdbbase,outFP);
dbWriteBreaktableFP(pdbbase,outFP);
dbWriteRecordFP(pdbbase,outFP,0,0);
free((void *)path);
free((void *)sub);
return 0;
}

90
src/ioc/dbStatic/dbReadTest.c
View File

@@ -1,90 +0,0 @@
/*************************************************************************\
* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
* National Laboratory.
* Copyright (c) 2002 The Regents of the University of California, as
* Operator of Los Alamos National Laboratory.
* EPICS BASE Versions 3.13.7
* and higher are distributed subject to a Software License Agreement found
* in file LICENSE that is included with this distribution.
\*************************************************************************/
/* dbReadTest.c */
/* Author: Marty Kraimer Date: 13JUL95 */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include "dbDefs.h"
#include "epicsPrint.h"
#include "errMdef.h"
#include "dbStaticLib.h"
#include "dbStaticPvt.h"
#include "dbBase.h"
#include "gpHash.h"
#include "osiFileName.h"
DBBASE *pdbbase = NULL;
int main(int argc,char **argv)
{
int i;
int strip;
char *path = NULL;
char *sub = NULL;
int pathLength = 0;
int subLength = 0;
char **pstr;
char *psep;
int *len;
long status;
static char *pathSep = OSI_PATH_LIST_SEPARATOR;
static char *subSep = ",";
/*Look for options*/
if(argc<2) {
printf("usage: dbReadTest -Idir -Smacsub file.dbd file.db \n");
exit(0);
}
while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
if(strncmp(argv[1],"-I",2)==0) {
pstr = &path;
psep = pathSep;
len = &pathLength;
} else {
pstr = &sub;
psep = subSep;
len = &subLength;
}
if(strlen(argv[1])==2) {
dbCatString(pstr,len,argv[2],psep);
strip = 2;
} else {
dbCatString(pstr,len,argv[1]+2,psep);
strip = 1;
}
argc -= strip;
for(i=1; i<argc; i++) argv[i] = argv[i + strip];
}
if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
printf("usage: dbReadTest -Idir -Idir file.dbd file.dbd \n");
exit(0);
}
for(i=1; i<argc; i++) {
status = dbReadDatabase(&pdbbase,argv[i],path,sub);
if(!status) continue;
fprintf(stderr,"For input file %s",argv[i]);
errMessage(status,"from dbReadDatabase");
}
/*
dbDumpRecordType(pdbbase,"ai");
dbDumpRecordType(pdbbase,NULL);
dbPvdDump(pdbbase,1);
gphDump(pdbbase->pgpHash);
dbDumpMenu(pdbbase,NULL);
dbDumpRecord(pdbbase,NULL,0);
dbReportDeviceConfig(pdbbase,stdout);
*/
dbFreeBase(pdbbase);
return(0);
}

124
src/ioc/dbStatic/dbToMenuH.c
View File

@@ -1,124 +0,0 @@
/*************************************************************************\
* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
* National Laboratory.
* Copyright (c) 2002 The Regents of the University of California, as
* Operator of Los Alamos National Laboratory.
* EPICS BASE Versions 3.13.7
* and higher are distributed subject to a Software License Agreement found
* in file LICENSE that is included with this distribution.
\*************************************************************************/
/* dbToMenu.c */
/* Author: Marty Kraimer Date: 11Sep95 */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include "dbDefs.h"
#include "epicsPrint.h"
#include "errMdef.h"
#include "dbStaticLib.h"
#include "dbStaticPvt.h"
#include "dbBase.h"
#include "gpHash.h"
#include "osiFileName.h"
DBBASE *pdbbase = NULL;
int main(int argc,char **argv)
{
dbMenu *pdbMenu;
char *outFilename;
char *pext;
FILE *outFile;
char *plastSlash;
int i;
int strip;
char *path = NULL;
char *sub = NULL;
int pathLength = 0;
int subLength = 0;
char **pstr;
char *psep;
int *len;
long status;
static char *pathSep = OSI_PATH_LIST_SEPARATOR;
static char *subSep = ",";
/*Look for options*/
if(argc<2) {
fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
exit(0);
}
while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
if(strncmp(argv[1],"-I",2)==0) {
pstr = &path;
psep = pathSep;
len = &pathLength;
} else {
pstr = &sub;
psep = subSep;
len = &subLength;
}
if(strlen(argv[1])==2) {
dbCatString(pstr,len,argv[2],psep);
strip = 2;
} else {
dbCatString(pstr,len,argv[1]+2,psep);
strip = 1;
}
argc -= strip;
for(i=1; i<argc; i++) argv[i] = argv[i + strip];
}
if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
exit(0);
}
if (argc==2) {
/*remove path so that outFile is created where program is executed*/
plastSlash = strrchr(argv[1],'/');
if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
outFilename = dbCalloc(1,strlen(plastSlash)+1);
strcpy(outFilename,plastSlash);
pext = strstr(outFilename,".dbd");
if (!pext) {
fprintf(stderr,"Input file MUST have .dbd extension\n");
exit(-1);
}
strcpy(pext,".h");
} else {
outFilename = dbCalloc(1,strlen(argv[2])+1);
strcpy(outFilename,argv[2]);
}
pdbbase = dbAllocBase();
pdbbase->ignoreMissingMenus = TRUE;
status = dbReadDatabase(&pdbbase,argv[1],path,sub);
if (status) {
errlogFlush();
fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
exit(1);
}
outFile = fopen(outFilename, "w");
if (!outFile) {
epicsPrintf("Error creating output file \"%s\"\n", outFilename);
exit(1);
}
pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
while(pdbMenu) {
fprintf(outFile,"#ifndef INC%sH\n",pdbMenu->name);
fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
fprintf(outFile,"typedef enum {\n");
for(i=0; i<pdbMenu->nChoice; i++) {
fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
fprintf(outFile,"\n");
}
fprintf(outFile,"}%s;\n",pdbMenu->name);
fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
}
fclose(outFile);
free((void *)outFilename);
return(0);
}

267
src/ioc/dbStatic/dbToRecordtypeH.c
View File

@@ -1,267 +0,0 @@
/*************************************************************************\
* Copyright (c) 2007 UChicago Argonne LLC, as Operator of Argonne
* National Laboratory.
* Copyright (c) 2002 The Regents of the University of California, as
* Operator of Los Alamos National Laboratory.
* EPICS BASE is distributed subject to a Software License Agreement found
* in file LICENSE that is included with this distribution.
\*************************************************************************/
/* dbToRecordtypeH.c */
/* Author: Marty Kraimer Date: 11Sep95 */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "dbDefs.h"
#include "epicsPrint.h"
#include "errMdef.h"
#include "dbStaticLib.h"
#include "dbStaticPvt.h"
#include "dbBase.h"
#include "gpHash.h"
#include "osiFileName.h"
DBBASE *pdbbase = NULL;
int main(int argc,char **argv)
{
int i;
char *outFilename;
char *pext;
FILE *outFile;
dbMenu *pdbMenu;
dbRecordType *pdbRecordType;
dbFldDes *pdbFldDes;
dbText *pdbCdef;
int isdbCommonRecord = FALSE;
char *plastSlash;
int strip;
char *path = NULL;
char *sub = NULL;
int pathLength = 0;
int subLength = 0;
char **pstr;
char *psep;
int *len;
long status;
static char *pathSep = OSI_PATH_LIST_SEPARATOR;
static char *subSep = ",";
/*Look for options*/
if(argc<2) {
fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
exit(0);
}
while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
if(strncmp(argv[1],"-I",2)==0) {
pstr = &path;
psep = pathSep;
len = &pathLength;
} else {
pstr = &sub;
psep = subSep;
len = &subLength;
}
if(strlen(argv[1])==2) {
dbCatString(pstr,len,argv[2],psep);
strip = 2;
} else {
dbCatString(pstr,len,argv[1]+2,psep);
strip = 1;
}
argc -= strip;
for(i=1; i<argc; i++) argv[i] = argv[i + strip];
}
if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
exit(0);
}
if(argc==2){
/*remove path so that outFile is created where program is executed*/
plastSlash = strrchr(argv[1],'/');
if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
outFilename = dbCalloc(1,strlen(plastSlash)+1);
strcpy(outFilename,plastSlash);
pext = strstr(outFilename,".dbd");
if(!pext) {
fprintf(stderr,"Input file MUST have .dbd extension\n");
exit(-1);
}
strcpy(pext,".h");
if(strcmp(outFilename,"dbCommonRecord.h")==0) {
strcpy(outFilename,"dbCommon.h");
isdbCommonRecord = TRUE;
}
}else {
outFilename = dbCalloc(1,strlen(argv[2])+1);
strcpy(outFilename,argv[2]);
if(strstr(outFilename,"dbCommon.h")!=0) {
isdbCommonRecord = TRUE;
}
}
pdbbase = dbAllocBase();
pdbbase->ignoreMissingMenus = TRUE;
pdbbase->loadCdefs = TRUE;
status = dbReadDatabase(&pdbbase,argv[1],path,sub);
if(status) {
errlogFlush();
fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
exit(1);
}
outFile = fopen(outFilename,"w");
if(!outFile) {
epicsPrintf("Error creating output file \"%s\"\n", outFilename);
exit(1);
}
pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
while(pdbMenu) {
fprintf(outFile,"\n#ifndef INC%sH\n",pdbMenu->name);
fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
fprintf(outFile,"typedef enum {\n");
for(i=0; i<pdbMenu->nChoice; i++) {
fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
fprintf(outFile,"\n");
}
fprintf(outFile,"}%s;\n",pdbMenu->name);
fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
}
pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
while(pdbRecordType) {
fprintf(outFile,"#ifndef INC%sH\n",pdbRecordType->name);
fprintf(outFile,"#define INC%sH\n",pdbRecordType->name);
pdbCdef = (dbText *)ellFirst(&pdbRecordType->cdefList);
while (pdbCdef) {
fprintf(outFile,"%s\n",pdbCdef->text);
pdbCdef = (dbText *)ellNext(&pdbCdef->node);
}
fprintf(outFile,"typedef struct %s",pdbRecordType->name);
if(!isdbCommonRecord) fprintf(outFile,"Record");
fprintf(outFile," {\n");
for(i=0; i<pdbRecordType->no_fields; i++) {
char name[256];
int j;
pdbFldDes = pdbRecordType->papFldDes[i];
for(j=0; j< (int)strlen(pdbFldDes->name); j++)
name[j] = tolower(pdbFldDes->name[j]);
name[strlen(pdbFldDes->name)] = 0;
switch(pdbFldDes->field_type) {
case DBF_STRING :
fprintf(outFile, "\tchar\t\t%s[%d];\t/* %s */\n",
name, pdbFldDes->size, pdbFldDes->prompt);
break;
case DBF_CHAR :
fprintf(outFile, "\tepicsInt8\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_UCHAR :
fprintf(outFile, "\tepicsUInt8\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_SHORT :
fprintf(outFile, "\tepicsInt16\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_USHORT :
fprintf(outFile, "\tepicsUInt16\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_LONG :
fprintf(outFile, "\tepicsInt32\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_ULONG :
fprintf(outFile, "\tepicsUInt32\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_FLOAT :
fprintf(outFile, "\tepicsFloat32\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_DOUBLE :
fprintf(outFile, "\tepicsFloat64\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_ENUM :
case DBF_MENU :
case DBF_DEVICE :
fprintf(outFile, "\tepicsEnum16\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_INLINK :
case DBF_OUTLINK :
case DBF_FWDLINK :
fprintf(outFile, "\tDBLINK\t\t%s;\t/* %s */\n",
name, pdbFldDes->prompt);
break;
case DBF_NOACCESS:
fprintf(outFile, "\t%s;\t/* %s */\n",
pdbFldDes->extra, pdbFldDes->prompt);
break;
default:
fprintf(outFile,"ILLEGAL FIELD TYPE\n");
}
}
fprintf(outFile,"} %s",pdbRecordType->name);
if(!isdbCommonRecord) fprintf(outFile,"Record");
fprintf(outFile,";\n");
if(!isdbCommonRecord) {
for(i=0; i<pdbRecordType->no_fields; i++) {
pdbFldDes = pdbRecordType->papFldDes[i];
fprintf(outFile,"#define %sRecord%s\t%d\n",
pdbRecordType->name,pdbFldDes->name,pdbFldDes->indRecordType);
}
}
fprintf(outFile,"#endif /*INC%sH*/\n",pdbRecordType->name);
pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
if(pdbRecordType) fprintf(outFile,"\n");
}
if(!isdbCommonRecord) {
fprintf(outFile,"#ifdef GEN_SIZE_OFFSET\n");
fprintf(outFile,"#ifdef __cplusplus\n");
fprintf(outFile,"extern \"C\" {\n");
fprintf(outFile,"#endif\n");
fprintf(outFile,"#include <epicsExport.h>\n");
pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
while(pdbRecordType) {
fprintf(outFile,"static int %sRecordSizeOffset(dbRecordType *pdbRecordType)\n{\n",
pdbRecordType->name);
fprintf(outFile," %sRecord *prec = 0;\n",pdbRecordType->name);
for(i=0; i<pdbRecordType->no_fields; i++) {
char name[256];
int j;
pdbFldDes = pdbRecordType->papFldDes[i];
for(j=0; j< (int)strlen(pdbFldDes->name); j++)
name[j] = tolower(pdbFldDes->name[j]);
name[strlen(pdbFldDes->name)] = 0;
fprintf(outFile,
" pdbRecordType->papFldDes[%d]->size=sizeof(prec->%s);\n",
i,name);
fprintf(outFile," pdbRecordType->papFldDes[%d]->offset=",i);
fprintf(outFile,
"(short)((char *)&prec->%s - (char *)prec);\n",name);
}
fprintf(outFile," pdbRecordType->rec_size = sizeof(*prec);\n");
fprintf(outFile," return(0);\n");
fprintf(outFile,"}\n");
fprintf(outFile,"epicsExportRegistrar(%sRecordSizeOffset);\n",
pdbRecordType->name);
pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
}
fprintf(outFile,"#ifdef __cplusplus\n");
fprintf(outFile,"}\n");
fprintf(outFile,"#endif\n");
fprintf(outFile,"#endif /*GEN_SIZE_OFFSET*/\n");
}
fclose(outFile);
free((void *)outFilename);
return(0);
}

295
src/ioc/registry/registerRecordDeviceDriver.pl
View File

@@ -1,7 +1,7 @@
eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*-
if $running_under_some_shell; # registerRecordDeviceDriver
#*************************************************************************
# Copyright (c) 2009 UChicago Argonne LLC, as Operator of Argonne
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# Copyright (c) 2002 The Regents of the University of California, as
# Operator of Los Alamos National Laboratory.
@@ -9,52 +9,35 @@ eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*-
# in file LICENSE that is included with this distribution.
#*************************************************************************
use strict;
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Path;
($file, $subname, $bldTop) = @ARGV;
$numberRecordType = 0;
$numberDeviceSupport = 0;
$numberDriverSupport = 0;
use DBD;
use DBD::Parser;
use EPICS::Readfile;
use EPICS::Path;
use Text::Wrap;
my ($file, $subname, $bldTop) = @ARGV;
my $dbd = DBD->new();
&ParseDBD($dbd, &Readfile($file));
$Text::Wrap::columns = 75;
# Eliminate chars not allowed in C symbol names
$c_bad_ident_chars = '[^0-9A-Za-z_]';
my $c_bad_ident_chars = '[^0-9A-Za-z_]';
$subname =~ s/$c_bad_ident_chars/_/g;
# Process bldTop like convertRelease.pl does
$bldTop = LocalPath(UnixPath($bldTop));
$bldTop =~ s/([\\"])/\\\1/g; # escape back-slashes and double-quotes
open(INP,"$file") or die "$! opening file";
while(<INP>) {
next if m/ ^ \s* \# /x;
if (m/ \b recordtype \s* \( \s* (\w+) \s* \) /x) {
$recordType[$numberRecordType++] = $1;
}
elsif (m/ \b device \s* \( \s* (\w+) \W+ \w+ \W+ (\w+) /x) {
$deviceRecordType[$numberDeviceSupport] = $1;
$deviceSupport[$numberDeviceSupport] = $2;
$numberDeviceSupport++;
}
elsif (m/ \b driver \s* \( \s* (\w+) \s* \) /x) {
$driverSupport[$numberDriverSupport++] = $1;
}
elsif (m/ \b registrar \s* \( \s* (\w+) \s* \) /x) {
push @registrars, $1;
}
elsif (m/ \b function \s* \( \s* (\w+) \s* \) /x) {
push @registrars, "register_func_$1";
}
elsif (m/ \b variable \s* \( \s* (\w+) \s* , \s* (\w+) \s* \) /x) {
$varType{$1} = $2;
push @variables, $1;
}
}
close(INP) or die "$! closing file";
# Start of generated file
# beginning of generated routine
print << "END" ;
/* THIS IS A GENERATED FILE. DO NOT EDIT! */
/* Generated from $file */
@@ -70,104 +53,115 @@ extern "C" {
END
#definitions for recordtype
if($numberRecordType>0) {
for ($i=0; $i<$numberRecordType; $i++) {
print "epicsShareExtern rset *pvar_rset_$recordType[$i]RSET;\n";
print "epicsShareExtern int (*pvar_func_$recordType[$i]RecordSizeOffset)(dbRecordType *pdbRecordType);\n"
my %rectypes = %{$dbd->recordtypes};
my @dsets;
if (%rectypes) {
my @rtypnames = sort keys %rectypes;
# Declare the record support entry tables
print wrap('epicsShareExtern rset ', ' ',
join(', ', map {"*pvar_rset_${_}RSET"} @rtypnames)), ";\n\n";
# Declare the RecordSizeOffset functions
print "typedef int (*rso_func)(dbRecordType *pdbRecordType);\n";
print wrap('epicsShareExtern rso_func ', ' ',
join(', ', map {"pvar_func_${_}RecordSizeOffset"} @rtypnames)), ";\n\n";
# List of record type names
print "static const char * const recordTypeNames[] = {\n";
print wrap(' ', ' ', join(', ', map {"\"$_\""} @rtypnames));
print "\n};\n\n";
# List of pointers to each RSET and RecordSizeOffset function
print "static const recordTypeLocation rtl[] = {\n";
print join(",\n", map {
" {pvar_rset_${_}RSET, pvar_func_${_}RecordSizeOffset}"
} @rtypnames);
print "\n};\n\n";
for my $rtype (@rtypnames) {
my @devices = $rectypes{$rtype}->devices;
for my $dtype (@devices) {
my $dset = $dtype->name;
push @dsets, $dset;
}
}
print "\nstatic const char * const recordTypeNames[$numberRecordType] = {\n";
for ($i=0; $i<$numberRecordType; $i++) {
print " \"$recordType[$i]\"";
if($i < $numberRecordType-1) { print ",";}
print "\n";
if (@dsets) {
# Declare the device support entry tables
print wrap('epicsShareExtern dset ', ' ',
join(', ', map {"*pvar_dset_$_"} @dsets)), ";\n\n";
# List of dset names
print "static const char * const deviceSupportNames[] = {\n";
print wrap(' ', ' ', join(', ', map {"\"$_\""} @dsets));
print "\n};\n\n";
# List of pointers to each dset
print "static const dset * const devsl[] = {\n";
print wrap(' ', ' ', join(", ", map {"pvar_dset_$_"} @dsets));
print "\n};\n\n";
}
}
my %drivers = %{$dbd->drivers};
if (%drivers) {
my @drivers = sort keys %drivers;
# Declare the driver entry tables
print wrap('epicsShareExtern drvet ', ' ',
join(', ', map {"*pvar_drvet_$_"} @drivers)), ";\n\n";
# List of drvet names
print "static const char *driverSupportNames[] = {\n";
print wrap(' ', ' ', join(', ', map {"\"$_\""} @drivers));
print "};\n\n";
print "static const recordTypeLocation rtl[$i] = {\n";
for ($i=0; $i<$numberRecordType; $i++) {
print " {pvar_rset_$recordType[$i]RSET, pvar_func_$recordType[$i]RecordSizeOffset}";
if($i < $numberRecordType-1) { print ",";}
print "\n";
}
# List of pointers to each drvet
print "static struct drvet *drvsl[] = {\n";
print join(",\n", map {" pvar_drvet_$_"} @drivers);
print "};\n\n";
}
#definitions for device
if($numberDeviceSupport>0) {
for ($i=0; $i<$numberDeviceSupport; $i++) {
print "epicsShareExtern dset *pvar_dset_$deviceSupport[$i];\n";
}
print "\nstatic const char * const deviceSupportNames[$numberDeviceSupport] = {\n";
for ($i=0; $i<$numberDeviceSupport; $i++) {
print " \"$deviceSupport[$i]\"";
if($i < $numberDeviceSupport-1) { print ",";}
print "\n";
}
print "};\n\n";
print "static const dset * const devsl[$i] = {\n";
for ($i=0; $i<$numberDeviceSupport; $i++) {
print " pvar_dset_$deviceSupport[$i]";
if($i < $numberDeviceSupport-1) { print ",";}
print "\n";
}
print "};\n\n";
my @registrars = sort keys %{$dbd->registrars};
my @functions = sort keys %{$dbd->functions};
push @registrars, map {"register_func_$_"} @functions;
if (@registrars) {
# Declare the registrar functions
print "typedef void (*reg_func)(void);\n";
print wrap('epicsShareExtern reg_func ', ' ',
join(', ', map {"pvar_func_$_"} @registrars)), ";\n\n";
}
#definitions for driver
if($numberDriverSupport>0) {
for ($i=0; $i<$numberDriverSupport; $i++) {
print "epicsShareExtern drvet *pvar_drvet_$driverSupport[$i];\n";
my %variables = %{$dbd->variables};
if (%variables) {
my @varnames = sort keys %variables;
# Declare the variables
for my $var (@varnames) {
my $vtype = $variables{$var}->var_type;
print "epicsShareExtern $vtype * const pvar_${vtype}_$var;\n";
}
print "\nstatic const char *driverSupportNames[$numberDriverSupport] = {\n";
for ($i=0; $i<$numberDriverSupport; $i++) {
print " \"$driverSupport[$i]\"";
if($i < $numberDriverSupport-1) { print ",";}
print "\n";
# Generate the structure for registering variables with iocsh
print "\nstatic struct iocshVarDef vardefs[] = {\n";
for my $var (@varnames) {
my $vtype = $variables{$var}->var_type;
my $itype = $variables{$var}->iocshArg_type;
print " {\"$var\", $itype, pvar_${vtype}_$var},\n";
}
print "};\n\n";
print "static struct drvet *drvsl[$i] = {\n";
for ($i=0; $i<$numberDriverSupport; $i++) {
print " pvar_drvet_$driverSupport[$i]";
if($i < $numberDriverSupport-1) { print ",";}
print "\n";
}
print "};\n\n";
print " {NULL, iocshArgInt, NULL}\n};\n\n";
}
#definitions registrar
if(@registrars) {
foreach $reg (@registrars) {
print "epicsShareExtern void (*pvar_func_$reg)(void);\n";
}
print "\n";
}
# Now for actual registration routine
if (@variables) {
foreach $var (@variables) {
print "epicsShareExtern $varType{$var} *pvar_$varType{$var}_$var;\n";
}
%iocshTypes = (
'int' => 'iocshArgInt',
'double' => 'iocshArgDouble'
);
print "static struct iocshVarDef vardefs[] = {\n";
foreach $var (@variables) {
$argType = $iocshTypes{$varType{$var}};
die "Unknown variable type $varType{$var} for variable $var"
unless $argType;
print "\t{\"$var\", $argType, (void * const)pvar_$varType{$var}_$var},\n";
}
print "\t{NULL, iocshArgInt, NULL}\n};\n\n";
}
print << "END";
int $subname(DBBASE *pbase)
{
static int executed = 0;
END
#Now actual registration code.
print "int $subname(DBBASE *pbase)\n{\n";
print << "END" if ($bldTop ne '') ;
print << "END" if $bldTop ne '';
const char *bldTop = "$bldTop";
const char *envTop = getenv("TOP");
@@ -179,57 +173,62 @@ print << "END" if ($bldTop ne '') ;
END
print << "END" ;
print << 'END';
if (!pbase) {
printf("pdbbase is NULL; you must load a DBD file first.\\n");
printf("pdbbase is NULL; you must load a DBD file first.\n");
return -1;
}
if (executed) {
printf("Registration already done.\n");
return 0;
}
executed = 1;
END
if($numberRecordType>0) {
print " registerRecordTypes(pbase, $numberRecordType, ",
"recordTypeNames, rtl);\n";
}
if($numberDeviceSupport>0) {
print " registerDevices(pbase, $numberDeviceSupport, ",
"deviceSupportNames, devsl);\n";
}
if($numberDriverSupport>0) {
print " registerDrivers(pbase, $numberDriverSupport, ",
"driverSupportNames, drvsl);\n";
}
foreach $reg (@registrars) {
print " (*pvar_func_$reg)();\n";
}
print << 'END' if %rectypes;
registerRecordTypes(pbase, NELEMENTS(rtl), recordTypeNames, rtl);
END
if (@variables) {
print " iocshRegisterVariable(vardefs);\n";
}
print << "END" ;
print << 'END' if @dsets;
registerDevices(pbase, NELEMENTS(devsl), deviceSupportNames, devsl);
END
print << 'END' if %drivers;
registerDrivers(pbase, NELEMENTS(drvsl), driverSupportNames, drvsl);
END
print << "END" for @registrars;
pvar_func_$_();
END
print << 'END' if %variables;
iocshRegisterVariable(vardefs);
END
print << "END";
return 0;
}
/* registerRecordDeviceDriver */
static const iocshArg registerRecordDeviceDriverArg0 =
{"pdbbase",iocshArgPdbbase};
static const iocshArg *registerRecordDeviceDriverArgs[1] =
{&registerRecordDeviceDriverArg0};
static const iocshFuncDef registerRecordDeviceDriverFuncDef =
{"$subname",1,registerRecordDeviceDriverArgs};
static void registerRecordDeviceDriverCallFunc(const iocshArgBuf *)
/* $subname */
static const iocshArg rrddArg0 = {"pdbbase", iocshArgPdbbase};
static const iocshArg *rrddArgs[] = {&rrddArg0};
static const iocshFuncDef rrddFuncDef =
{"$subname", 1, rrddArgs};
static void rrddCallFunc(const iocshArgBuf *)
{
$subname(*iocshPpdbbase);
}
} // extern "C"
/*
* Register commands on application startup
*/
static int Registration() {
iocshRegisterCommon();
iocshRegister(&registerRecordDeviceDriverFuncDef,
registerRecordDeviceDriverCallFunc);
iocshRegister(&rrddFuncDef, rrddCallFunc);
return 0;
}

81
src/tools/DBD.pm Normal file
View File

@@ -0,0 +1,81 @@
package DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
use Carp;
sub new {
my ($class) = @_;
my $this = {
'DBD::Breaktable' => {},
'DBD::Driver' => {},
'DBD::Function' => {},
'DBD::Menu' => {},
'DBD::Recordtype' => {},
'DBD::Registrar' => {},
'DBD::Variable' => {}
};
bless $this, $class;
return $this;
}
sub add {
my ($this, $obj) = @_;
my $obj_class;
foreach (keys %{$this}) {
next unless m/^DBD::/;
$obj_class = $_ and last if $obj->isa($_);
}
confess "Unknown object type"
unless defined $obj_class;
my $obj_name = $obj->name;
dieContext("Duplicate name '$obj_name'")
if exists $this->{$obj_class}->{$obj_name};
$this->{$obj_class}->{$obj_name} = $obj;
}
sub breaktables {
return shift->{'DBD::Breaktable'};
}
sub drivers {
return shift->{'DBD::Driver'};
}
sub functions {
return shift->{'DBD::Function'};
}
sub menus {
return shift->{'DBD::Menu'};
}
sub menu {
my ($this, $menu_name) = @_;
return $this->{'DBD::Menu'}->{$menu_name};
}
sub recordtypes {
return shift->{'DBD::Recordtype'};
}
sub recordtype {
my ($this, $rtyp_name) = @_;
return $this->{'DBD::Recordtype'}->{$rtyp_name};
}
sub registrars {
return shift->{'DBD::Registrar'};
}
sub variables {
return shift->{'DBD::Variable'};
}
1;

127
src/tools/DBD/Base.pm Normal file
View File

@@ -0,0 +1,127 @@
# 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("Exiting context \"$ctxt\", found \"$pop\" instead.",
"\tBraces must close in the same file they were opened.");
}
sub dieContext {
my ($msg) = join "\n\t", @_;
print "$msg\n" if $msg;
die "Context: ", join(' in ', @context), "\n";
}
sub warnContext {
my ($msg) = join "\n\t", @_;
print "$msg\n" if $msg;
print "Context: ", 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 "$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);
return $this;
}
sub name {
return shift->{NAME};
}
1;

32
src/tools/DBD/Breaktable.pm Normal file
View File

@@ -0,0 +1,32 @@
package DBD::Breaktable;
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "breakpoint table name");
$this->{POINT_LIST} = [];
return $this;
}
sub add_point {
my ($this, $raw, $eng) = @_;
confess "Raw value undefined!" unless defined $raw;
confess "Engineering value undefined!" unless defined $eng;
unquote $raw;
unquote $eng;
push @{$this->{POINT_LIST}}, [$raw, $eng];
}
sub points {
return @{shift->{POINT_LIST}};
}
sub point {
my ($this, $idx) = @_;
return $this->{POINT_LIST}[$idx];
}
1;

45
src/tools/DBD/Device.pm Normal file
View File

@@ -0,0 +1,45 @@
package DBD::Device;
use DBD::Base;
@ISA = qw(DBD::Base);
my %link_types = (
CONSTANT => qr/$RXnum/o,
PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/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,
INST_IO => qr/@.*/
);
sub init {
my ($this, $link_type, $dset, $choice) = @_;
unquote $choice;
dieContext("Unknown link type '$link_type', valid types are:",
sort keys %link_types) unless exists $link_types{$link_type};
$this->SUPER::init($dset, "DSET name");
$this->{LINK_TYPE} = $link_type;
$this->{CHOICE} = $choice;
return $this;
}
sub link_type {
return shift->{LINK_TYPE};
}
sub choice {
return shift->{CHOICE};
}
sub legal_addr {
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
unquote $addr;
return $addr =~ m/^ $rx $/x;
}
1;

9
src/tools/DBD/Driver.pm Normal file
View File

@@ -0,0 +1,9 @@
package DBD::Driver;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "driver entry table name");
}
1;

10
src/tools/DBD/Function.pm Normal file
View File

@@ -0,0 +1,10 @@
package DBD::Function;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "function name");
}
1;

66
src/tools/DBD/Menu.pm Normal file
View File

@@ -0,0 +1,66 @@
package DBD::Menu;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "menu name");
$this->{CHOICE_LIST} = [];
$this->{CHOICE_INDEX} = {};
return $this;
}
sub add_choice {
my ($this, $name, $value) = @_;
$name = identifier($name, "Choice name");
unquote $value;
foreach $pair ($this->choices) {
dieContext("Duplicate choice name") if ($pair->[0] eq $name);
dieContext("Duplicate choice string") if ($pair->[1] eq $value);
}
push @{$this->{CHOICE_LIST}}, [$name, $value];
$this->{CHOICE_INDEX}->{$value} = $name;
}
sub choices {
return @{shift->{CHOICE_LIST}};
}
sub choice {
my ($this, $idx) = @_;
return $this->{CHOICE_LIST}[$idx];
}
sub legal_choice {
my ($this, $value) = @_;
unquote $value;
return exists $this->{CHOICE_INDEX}->{$value};
}
sub toDeclaration {
my $this = shift;
my $name = $this->name;
my @choices = map {
sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
} $this->choices;
return "typedef enum {\n" .
join(",\n", @choices) .
",\n ${name}_NUM_CHOICES\n" .
"} $name;\n\n";
}
sub toDefinition {
my $this = shift;
my $name = $this->name;
my @strings = map {
"\t\"" . escapeCstring(@{$_}[1]) . "\""
} $this->choices;
return "static const char * const ${name}ChoiceStrings[] = {\n" .
join(",\n", @strings) . "\n};\n" .
"const dbMenu ${name}MenuMetaData = {\n" .
"\t\"" . escapeCstring($name) . "\",\n" .
"\t${name}_NUM_CHOICES,\n" .
"\t${name}ChoiceStrings\n};\n\n";
}
1;

98
src/tools/DBD/Output.pm Normal file
View File

@@ -0,0 +1,98 @@
package DBD::Output;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&OutputDBD);
use DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
sub OutputDBD {
my ($out, $dbd) = @_;
&OutputMenus($out, $dbd->menus);
&OutputRecordtypes($out, $dbd->recordtypes);
&OutputDrivers($out, $dbd->drivers);
&OutputRegistrars($out, $dbd->registrars);
&OutputFunctions($out, $dbd->functions);
&OutputVariables($out, $dbd->variables);
&OutputBreaktables($out, $dbd->breaktables);
}
sub OutputMenus {
my ($out, $menus) = @_;
while (my ($name, $menu) = each %{$menus}) {
printf $out "menu(%s) {\n", $name;
printf $out " choice(%s, \"%s\")\n", @{$_}
foreach $menu->choices;
print $out "}\n";
}
}
sub OutputRecordtypes {
my ($out, $recordtypes) = @_;
while (my ($name, $recordtype) = each %{$recordtypes}) {
printf $out "recordtype(%s) {\n", $name;
print $out " %$_\n"
foreach $recordtype->cdefs;
foreach $field ($recordtype->fields) {
printf $out " field(%s, %s) {\n",
$field->name, $field->dbf_type;
while (my ($attr, $val) = each %{$field->attributes}) {
$val = "\"$val\"" if $val !~ m/^[a-zA-Z0-9_\-+:.\[\]<>;]*$/;
printf $out " %s(%s)\n", $attr, $val;
}
print $out " }\n";
}
printf $out "}\n";
printf $out "device(%s, %s, %s, \"%s\")\n",
$name, $_->link_type, $_->name, $_->choice
foreach $recordtype->devices;
}
}
sub OutputDrivers {
my ($out, $drivers) = @_;
printf $out "driver(%s)\n", $_
foreach keys %{$drivers};
}
sub OutputRegistrars {
my ($out, $registrars) = @_;
printf $out "registrar(%s)\n", $_
foreach keys %{$registrars};
}
sub OutputFunctions {
my ($out, $functions) = @_;
printf $out "function(%s)\n", $_
foreach keys %{$functions};
}
sub OutputVariables {
my ($out, $variables) = @_;
while (my ($name, $variable) = each %{$variables}) {
printf $out "variable(%s, %s)\n", $name, $variable->var_type;
}
}
sub OutputBreaktables {
my ($out, $breaktables) = @_;
while (my ($name, $breaktable) = each %{$breaktables}) {
printf $out "breaktable(\"%s\") {\n", $name;
printf $out " point(%s, %s)\n", @{$_}
foreach $breaktable->points;
print $out "}\n";
}
}
1;

197
src/tools/DBD/Parser.pm Normal file
View File

@@ -0,0 +1,197 @@
package DBD::Parser;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&ParseDBD);
use DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
our $debug=0;
sub ParseDBD {
my $dbd = shift;
$_ = shift;
while (1) {
parseCommon();
if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Menu: $1\n" if $debug;
parse_menu($dbd, $1);
}
elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
print "Driver: $1\n" if $debug;
$dbd->add(DBD::Driver->new($1));
}
elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
print "Registrar: $1\n" if $debug;
$dbd->add(DBD::Registrar->new($1));
}
elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
print "Function: $1\n" if $debug;
$dbd->add(DBD::Function->new($1));
}
elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Breaktable: $1\n" if $debug;
parse_breaktable($dbd, $1);
}
elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Recordtype: $1\n" if $debug;
parse_recordtype($dbd, $1);
}
elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
print "Variable: $1\n" if $debug;
$dbd->add(DBD::Variable->new($1, 'int'));
}
elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
print "Variable: $1, $2\n" if $debug;
$dbd->add(DBD::Variable->new($1, $2));
}
elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
\s* $string \s* , \s*$string \s* \)/oxgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
my $rtyp = $dbd->recordtype($1);
dieContext("Unknown record type '$1'") unless defined $rtyp;
$rtyp->add_device(DBD::Device->new($2, $3, $4));
} else {
last unless m/\G (.*) $/moxgc;
dieContext("Syntax error in '$1'");
}
}
}
sub parseCommon {
while (1) {
# Skip leading whitespace
m/\G \s* /oxgc;
if (m/\G \# /oxgc) {
if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
print "File-Begin: $1\n" if $debug;
pushContext("file '$1'");
}
elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) {
print "File-End: $1\n" if $debug;
popContext("file '$1'");
}
else {
m/\G (.*) \n/oxgc;
print "Comment: $1\n" if $debug;
}
} else {
return;
}
}
}
sub parse_menu {
my ($dbd, $name) = @_;
pushContext("menu($name)");
my $menu = DBD::Menu->new($name);
while(1) {
parseCommon();
if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
print " Menu-Choice: $1, $2\n" if $debug;
$menu->add_choice($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Menu-End:\n" if $debug;
$dbd->add($menu);
popContext("menu($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_breaktable {
my ($dbd, $name) = @_;
pushContext("breaktable($name)");
my $bt = DBD::Breaktable->new($name);
while(1) {
parseCommon();
if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
print " Breaktable-Point: $1, $2\n" if $debug;
$bt->add_point($1, $2);
}
elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
print " Breaktable-Data: $1, $2\n" if $debug;
$bt->add_point($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Breaktable-End:\n" if $debug;
$dbd->add($bt);
popContext("breaktable($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_recordtype {
my ($dbd, $name) = @_;
pushContext("recordtype($name)");
my $rtyp = DBD::Recordtype->new($name);
while(1) {
parseCommon();
if (m/\G field \s* \( \s* $string \s* , \s* $string \s* \) \s* \{/oxgc) {
print " Recordtype-Field: $1, $2\n" if $debug;
parse_field($rtyp, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Recordtype-End:\n" if $debug;
$dbd->add($rtyp);
popContext("recordtype($name)");
return;
}
elsif (m/\G % (.*) \n/oxgc) {
print " Recordtype-Cdef: $1\n" if $debug;
$rtyp->add_cdef($1);
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_field {
my ($rtyp, $name, $field_type) = @_;
my $fld = DBD::Recfield->new($name, $field_type);
pushContext("field($name, $field_type)");
while(1) {
parseCommon();
if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
print " Field-Attribute: $1, $2\n" if $debug;
$fld->add_attribute($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Field-End:\n" if $debug;
$rtyp->add_field($fld);
popContext("field($name, $field_type)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
1;

436
src/tools/DBD/Recfield.pm Normal file
View File

@@ -0,0 +1,436 @@
package DBD::Recfield;
use DBD::Base;
@ISA = qw(DBD::Base);
# The hash value is a regexp that matches all legal values of this field
our %field_types = (
DBF_STRING => qr/.{0,40}/,
DBF_CHAR => $RXintx,
DBF_UCHAR => $RXuintx,
DBF_SHORT => $RXintx,
DBF_USHORT => $RXuintx,
DBF_LONG => $RXintx,
DBF_ULONG => $RXuintx,
DBF_FLOAT => $RXnum,
DBF_DOUBLE => $RXnum,
DBF_ENUM => qr/.*/,
DBF_MENU => qr/.*/,
DBF_DEVICE => qr/.*/,
DBF_INLINK => qr/.*/,
DBF_OUTLINK => qr/.*/,
DBF_FWDLINK => qr/.*/,
DBF_NOACCESS => qr//
);
# The hash value is a regexp that matches all legal values of this attribute
our %field_attrs = (
asl => qr/^ASL[01]$/,
initial => qr/^.*$/,
promptgroup => qr/^GUI_\w+$/,
prompt => qr/^.*$/,
special => qr/^(?:SPC_\w+|\d{3,})$/,
pp => qr/^(?:TRUE|FALSE)$/,
interest => qr/^\d+$/,
base => qr/^(?:DECIMAL|HEX)$/,
size => qr/^\d+$/,
extra => qr/^.*$/,
menu => qr/^$RXident$/o
);
sub new {
my ($class, $name, $type) = @_;
dieContext("Illegal field type '$type', valid field types are:",
sort keys %field_types) unless exists $field_types{$type};
my $this = {};
bless $this, "${class}::${type}";
return $this->init($name, $type);
}
sub init {
my ($this, $name, $type) = @_;
unquote $type;
$this->SUPER::init($name, "record field name");
dieContext("Illegal field type '$type', valid field types are:",
sort keys %field_types) unless exists $field_types{$type};
$this->{DBF_TYPE} = $type;
$this->{ATTR_INDEX} = {};
return $this;
}
sub dbf_type {
return shift->{DBF_TYPE};
}
sub set_number {
my ($this, $number) = @_;
$this->{NUMBER} = $number;
}
sub number {
return shift->{NUMBER};
}
sub add_attribute {
my ($this, $attr, $value) = @_;
unquote $value;
my $match = $field_attrs{$attr};
dieContext("Unknown field attribute '$1', valid attributes are:",
sort keys %field_attrs)
unless defined $match;
dieContext("Bad value '$value' for field '$attr' attribute")
unless $value =~ m/$match/;
$this->{ATTR_INDEX}->{$attr} = $value;
}
sub attributes {
return shift->{ATTR_INDEX};
}
sub attribute {
my ($this, $attr) = @_;
return $this->attributes->{$attr};
}
sub check_valid {
my ($this) = @_;
my $name = $this->name;
my $default = $this->attribute("initial");
dieContext("Default value '$default' is invalid for field '$name'")
if (defined($default) and !$this->legal_value($default));
}
# The C structure member name is usually the field name converted to
# lower-case. However if that is a reserved word, use the original.
sub C_name {
my ($this) = @_;
my $name = lc $this->name;
$name = $this->name
if is_reserved($name);
return $name;
}
sub toDeclaration {
my ($this, $ctype) = @_;
my $name = $this->C_name;
my $result = sprintf " %-19s %-12s", $ctype, "$name;";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
################################################################################
package DBD::Recfield::DBF_STRING;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return (length $value < $this->attribute('size'));
# NB - we use '<' to allow space for the terminating nil byte
}
sub check_valid {
my ($this) = @_;
dieContext("Size missing for DBF_STRING field '$name'")
unless exists $this->attributes->{'size'};
$this->SUPER::check_valid;
}
sub toDeclaration {
my ($this) = @_;
my $name = lc $this->name;
my $size = $this->attribute('size');
my $result = sprintf " %-19s %-12s", 'char', "${name}[${size}];";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
################################################################################
package DBD::Recfield::DBF_CHAR;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x and
$value >= -128 and
$value <= 127);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt8");
}
################################################################################
package DBD::Recfield::DBF_UCHAR;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0 and
$value <= 255);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt8");
}
################################################################################
package DBD::Recfield::DBF_SHORT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x and
$value >= -32768 and
$value <= 32767);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt16");
}
################################################################################
package DBD::Recfield::DBF_USHORT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0 and
$value <= 65535);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt16");
}
################################################################################
package DBD::Recfield::DBF_LONG;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt32");
}
################################################################################
package DBD::Recfield::DBF_ULONG;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt32");
}
################################################################################
package DBD::Recfield::DBF_FLOAT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value =~ m/^ $RXnum $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsFloat32");
}
################################################################################
package DBD::Recfield::DBF_DOUBLE;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value =~ m/^ $RXnum $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsFloat64");
}
################################################################################
package DBD::Recfield::DBF_ENUM;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_MENU;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
# FIXME: If we know the menu name and the menu exists, check further
return 1;
}
sub check_valid {
my ($this) = @_;
dieContext("Menu name missing for DBF_MENU field '$name'")
unless defined($this->attribute("menu"));
$this->SUPER::check_valid;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_DEVICE;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_INLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_OUTLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_FWDLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_NOACCESS;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value eq '');
}
sub check_valid {
my ($this) = @_;
dieContext("Type information missing for DBF_NOACCESS field '$name'")
unless defined($this->attribute("extra"));
$this->SUPER::check_valid;
}
sub toDeclaration {
my ($this) = @_;
my $extra = $this->attribute('extra');
my $result = sprintf " %-31s ", "$extra;";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
1;

100
src/tools/DBD/Recordtype.pm Normal file
View File

@@ -0,0 +1,100 @@
package DBD::Recordtype;
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;
sub init {
my $this = shift;
$this->SUPER::init(@_);
$this->{FIELD_LIST} = [];
$this->{FIELD_INDEX} = {};
$this->{DEVICE_LIST} = [];
$this->{DEVICE_INDEX} = {};
$this->{CDEFS} = [];
return $this;
}
sub add_field {
my ($this, $field) = @_;
confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield');
my $field_name = $field->name;
dieContext("Duplicate field name '$field_name'")
if exists $this->{FIELD_INDEX}->{$field_name};
$field->check_valid;
$field->set_number(scalar @{$this->{FIELD_LIST}});
push @{$this->{FIELD_LIST}}, $field;
$this->{FIELD_INDEX}->{$field_name} = $field;
}
sub fields {
return @{shift->{FIELD_LIST}};
}
sub field_names { # In their original order...
my $this = shift;
my @names = ();
foreach ($this->fields) {
push @names, $_->name
}
return @names;
}
sub field {
my ($this, $field_name) = @_;
return $this->{FIELD_INDEX}->{$field_name};
}
sub add_device {
my ($this, $device) = @_;
confess "Not a DBD::Device" unless $device->isa('DBD::Device');
my $choice = $device->choice;
if (exists $this->{DEVICE_INDEX}->{$choice}) {
my @warning = ("Duplicate device type '$choice'");
my $old = $this->{DEVICE_INDEX}->{$choice};
push @warning, "Link types differ"
if ($old->link_type ne $device->link_type);
push @warning, "DSETs differ"
if ($old->name ne $device->name);
warnContext(@warning);
return;
}
push @{$this->{DEVICE_LIST}}, $device;
$this->{DEVICE_INDEX}->{$choice} = $device;
}
sub devices {
return @{shift->{DEVICE_LIST}};
}
sub device {
my ($this, $choice) = @_;
return $this->{DEVICE_INDEX}->{$choice};
}
sub add_cdef {
my ($this, $cdef) = @_;
push @{$this->{CDEFS}}, $cdef;
}
sub cdefs {
return @{shift->{CDEFS}};
}
sub toCdefs {
return join("\n", shift->cdefs) . "\n\n";
}
sub toDeclaration {
my $this = shift;
my @fields = map {
$_->toDeclaration
} $this->fields;
my $name = $this->name;
$name .= "Record" unless $name eq "dbCommon";
return "typedef struct $name {\n" .
join("\n", @fields) .
"\n} $name;\n\n";
}
1;

11
src/tools/DBD/Registrar.pm Normal file
View File

@@ -0,0 +1,11 @@
package DBD::Registrar;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "registrar function name");
}
1;

36
src/tools/DBD/Variable.pm Normal file
View File

@@ -0,0 +1,36 @@
package DBD::Variable;
use DBD::Base;
@ISA = qw(DBD::Base);
my %valid_types = (
# C type name => corresponding iocshArg type identifier
int => 'iocshArgInt',
double => 'iocshArgDouble'
);
sub init {
my ($this, $name, $type) = @_;
if (defined $type) {
unquote $type;
} else {
$type = "int";
}
exists $valid_types{$type} or
dieContext("Unknown variable type '$type', valid types are:",
sort keys %valid_types);
$this->SUPER::init($name, "variable name");
$this->{VAR_TYPE} = $type;
return $this;
}
sub var_type {
my $this = shift;
return $this->{VAR_TYPE};
}
sub iocshArg_type {
my $this = shift;
return $valid_types{$this->{VAR_TYPE}};
}
1;

101
src/tools/EPICS/Readfile.pm Normal file
View File

@@ -0,0 +1,101 @@
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
package EPICS::Readfile;
require 5.000;
require Exporter;
use EPICS::macLib;
@ISA = qw(Exporter);
@EXPORT = qw(@inputfiles &Readfile);
our $debug=0;
our @inputfiles;
sub slurp {
my ($FILE, $Rpath) = @_;
my @path = @{$Rpath};
print "slurp($FILE):\n" if $debug;
if ($FILE !~ m[/]) {
foreach $dir (@path) {
print " trying $dir/$FILE\n" if $debug;
if (-r "$dir/$FILE") {
$FILE = "$dir/$FILE";
last;
}
}
die "Can't find file '$FILE'\n" unless -r $FILE;
}
print " opening $FILE\n" if $debug;
open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
push @inputfiles, $FILE;
my @lines = ("##!BEGIN{$FILE}!##\n");
# Consider replacing these markers with C pre-processor linemarkers.
# See 'info cpp' * Preprocessor Output:: for details.
push @lines, <FILE>;
push @lines, "##!END{$FILE}!##\n";
close FILE or die "Error closing $FILE: $!\n";
print " read ", scalar @lines, " lines\n" if $debug;
return join '', @lines;
}
sub expandMacros {
my ($macros, $input) = @_;
return $input unless $macros;
return $macros->expandString($input);
}
sub splitPath {
my ($path) = @_;
my (@path) = split /[:;]/, $path;
grep s/^$/./, @path;
return @path;
}
my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
my $string = qr/ ( $RXnam | $RXstr ) /ox;
sub unquote {
my ($s) = @_;
$s =~ s/^"(.*)"$/$1/o;
return $s;
}
sub Readfile {
my ($file, $macros, $Rpath) = @_;
print "Readfile($file)\n" if $debug;
my $input = &expandMacros($macros, &slurp($file, $Rpath));
my @input = split /\n/, $input;
my @output;
foreach (@input) {
if (m/^ \s* include \s+ $string /ox) {
$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) {
$arg = &unquote($1);
print " addpath $arg\n" if $debug;
push @output, "##! addpath \"$arg\"";
push @{$Rpath}, &splitPath($arg);
} elsif (m/^ \s* path \s+ $string /ox) {
$arg = &unquote($1);
print " path $arg\n" if $debug;
push @output, "##! path \"$arg\"";
@{$Rpath} = &splitPath($arg);
} else {
push @output, $_;
}
}
return join "\n", @output;
}
1;

251
src/tools/EPICS/macLib.pm Normal file
View File

@@ -0,0 +1,251 @@
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
package EPICS::macLib::entry;
sub new ($$) {
my $class = shift;
my $this = {
name => shift,
type => shift,
raw => '',
val => '',
visited => 0,
error => 0,
};
bless $this, $class;
return $this;
}
sub report ($) {
my ($this) = @_;
return unless defined $this->{raw};
printf "%1s %-16s %-16s %s\n",
($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val};
}
package EPICS::macLib;
use Carp;
sub new ($@) {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {
dirty => 0,
noWarn => 0,
macros => [{}], # [0] is current scope, [1] is parent etc.
};
bless $this, $class;
$this->installList(@_);
return $this;
}
sub installList ($@) {
# Argument is a list of strings which are arguments to installMacros
my $this = shift;
while (@_) {
$this->installMacros(shift);
}
}
sub installMacros ($$) {
# Argument is a string: a=1,b="2",c,d='hello'
my $this = shift;
$_ = shift;
until (defined pos($_) and pos($_) == length($_)) {
m/\G \s* /xgc; # Skip whitespace
if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) {
my ($name, $val) = ($1);
if (m/\G = \s* /xgc) {
# The value follows, handle quotes and escapes
until (pos($_) == length($_)) {
if (m/\G , /xgc) { last; }
elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
elsif (m/\G \\ ( . ) /xgc) { $val .= $1; }
elsif (m/\G ( . ) /xgc) { $val .= $1; }
else { die "How did I get here?"; }
}
$this->putValue($name, $val);
} elsif (m/\G , /xgc or (pos($_) == length($_))) {
$this->putValue($name, undef);
} else {
warn "How did I get here?";
}
} elsif (m/\G ( .* )/xgc) {
croak "Can't find a macro definition in '$1'";
} else {
last;
}
}
}
sub putValue ($$$) {
my ($this, $name, $raw) = @_;
if (exists $this->{macros}[0]{$name}) {
if (!defined $raw) {
delete $this->{macros}[0]{$name};
} else {
$this->{macros}[0]{$name}{raw} = $raw;
}
} else {
my $entry = EPICS::macLib::entry->new($name, 'macro');
$entry->{raw} = $raw;
$this->{macros}[0]{$name} = $entry;
}
$this->{dirty} = 1;
}
sub pushScope ($) {
my ($this) = @_;
unshift @{$this->{macros}}, {};
}
sub popScope ($) {
my ($this) = @_;
shift @{$this->{macros}};
}
sub suppressWarning($$) {
my ($this, $suppress) = @_;
$this->{noWarn} = $suppress;
}
sub expandString($$) {
my ($this, $src) = @_;
$this->_expand;
my $entry = EPICS::macLib::entry->new($src, 'string');
my $result = $this->_translate($entry, 0, $src);
return $result unless $entry->{error};
return $this->{noWarn} ? $result : undef;
}
sub reportMacros ($) {
my ($this) = @_;
$this->_expand;
print "Macro report\n============\n";
foreach my $scope (@{$this->{macros}}) {
foreach my $name (keys %{$scope}) {
my $entry = $scope->{$name};
$entry->report;
}
} continue {
print " -- scope ends --\n";
}
}
# Private routines, not intended for public use
sub _expand ($) {
my ($this) = @_;
return unless $this->{dirty};
foreach my $scope (@{$this->{macros}}) {
foreach my $name (keys %{$scope}) {
my $entry = $scope->{$name};
$entry->{val} = $this->_translate($entry, 1, $entry->{raw});
}
}
$this->{dirty} = 0;
}
sub _lookup ($$$$$) {
my ($this, $name) = @_;
foreach my $scope (@{$this->{macros}}) {
if (exists $scope->{$name}) {
return undef # Macro marked as deleted
unless defined $scope->{$name}{raw};
return $scope->{$name};
}
}
return undef;
}
sub _translate ($$$$) {
my ($this, $entry, $level, $str) = @_;
return $this->_trans($entry, $level, '', \$str);
}
sub _trans ($$$$$) {
my ($this, $entry, $level, $term, $R) = @_;
return $$R
if (!defined $$R or
$$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
my $quote = 0;
my $val;
until (defined pos($$R) and pos($$R) == length($$R)) {
if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
last;
}
if ($$R =~ m/\G \$ ( [({] ) /xgc) {
my $macEnd = $1;
$macEnd =~ tr/({/)}/;
my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R);
my $entry2 = $this->_lookup($name2);
if (!defined $entry2) { # Macro not found
if ($$R =~ m/\G = /xgc) { # Use default value given
$val .= $this->_trans($entry, $level+1, $macEnd, $R);
} else {
unless ($this->{noWarn}) {
$entry->{error} = 1;
printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n",
$name2, $entry->{type}, $entry->{name};
}
$val .= "\$($name2)";
}
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
} else { # Macro found
if ($entry2->{visited}) {
$entry->{error} = 1;
printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n",
$entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name};
$val .= "\$($name)";
} else {
if ($$R =~ m/\G = /xgc) { # Discard default value
local $this->{noWarn} = 1; # Temporarily kill warnings
$this->_trans($entry, $level+1, $macEnd, $R);
}
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
if ($this->{dirty}) { # Translate raw value
$entry2->{visited} = 1;
$val .= $this->_trans($entry, $level+1, '', \$entry2->{raw});
$entry2->{visited} = 0;
} else {
$val .= $entry2->{val}; # Here's one I made earlier...
}
}
}
} elsif ($level > 0) { # Discard quotes and escapes
if ($quote and $$R =~ m/\G $quote /xgc) {
$quote = 0;
} elsif ($$R =~ m/\G ( ['"] ) /xgc) {
$quote = $1;
} elsif ($$R =~ m/\G \\? ( . ) /xgc) {
$val .= $1;
} else {
warn "How did I get here? level=$level";
}
} else { # Level 0
if ($$R =~ m/\G \\ ( . ) /xgc) {
$val .= "\\$1";
} elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) {
$val .= $1;
} elsif ($$R =~ m/\G ( . ) /xgc) {
$val .= $1;
} else {
warn "How did I get here? level=$level";
}
}
}
return $val;
}
1;

23
src/tools/Makefile
View File

@@ -1,5 +1,5 @@
#*************************************************************************
# Copyright (c) 2008 UChicago Argonne LLC, as Operator of Argonne
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
@@ -14,7 +14,23 @@ TOOLS = $(TOP)/src/tools
PERL_MODULES += EPICS/Copy.pm
PERL_MODULES += EPICS/Path.pm
PERL_MODULES += EPICS/Release.pm
PERL_MODULES += EPICS/Readfile.pm
PERL_MODULES += EPICS/Getopts.pm
PERL_MODULES += EPICS/macLib.pm
PERL_MODULES += DBD.pm
PERL_MODULES += DBD/Base.pm
PERL_MODULES += DBD/Breaktable.pm
PERL_MODULES += DBD/Device.pm
PERL_MODULES += DBD/Driver.pm
PERL_MODULES += DBD/Function.pm
PERL_MODULES += DBD/Menu.pm
PERL_MODULES += DBD/Output.pm
PERL_MODULES += DBD/Parser.pm
PERL_MODULES += DBD/Recfield.pm
PERL_MODULES += DBD/Recordtype.pm
PERL_MODULES += DBD/Registrar.pm
PERL_MODULES += DBD/Variable.pm
PERL_SCRIPTS += convertRelease.pl
PERL_SCRIPTS += cvsclean.pl
@@ -32,5 +48,10 @@ PERL_SCRIPTS += munch.pl
PERL_SCRIPTS += replaceVAR.pl
PERL_SCRIPTS += useManifestTool.pl
PERL_SCRIPTS += dbdToMenuH.pl
PERL_SCRIPTS += dbdToRecordtypeH.pl
PERL_SCRIPTS += dbdExpand.pl
PERL_SCRIPTS += dbdToHtml.pl
include $(TOP)/configure/RULES

53
src/tools/dbdExpand.pl Executable file
View File

@@ -0,0 +1,53 @@
#!/usr/bin/perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use DBD;
use DBD::Parser;
use DBD::Output;
use EPICS::Getopts;
use EPICS::Readfile;
use EPICS::macLib;
getopts('DI@S@o:') or
die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $macros = EPICS::macLib->new(@opt_S);
my $dbd = DBD->new();
while (@ARGV) {
&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
}
if ($opt_D) { # Output dependencies only
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
exit 0;
}
my $out;
if ($opt_o) {
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
} else {
$out = STDOUT;
}
&OutputDBD($out, $dbd);
if ($opt_o) {
close $out or die "Closing $opt_o failed: $!\n";
}
exit 0;

64
src/tools/dbdReport.pl Executable file
View File

@@ -0,0 +1,64 @@
#!/usr/bin/perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use DBD;
use DBD::Parser;
use EPICS::Getopts;
use EPICS::macLib;
use EPICS::Readfile;
use Text::Wrap;
#$EPICS::Readfile::debug = 1;
#$DBD::Parser::debug = 1;
getopts('I@S@') or die usage();
sub usage() {
"Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ...";
}
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $macros = EPICS::macLib->new(@opt_S);
my $dbd = DBD->new();
&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
$Text::Wrap::columns = 75;
my @menus = sort keys %{$dbd->menus};
print wrap("Menus:\t", "\t", join(', ', @menus)), "\n"
if @menus;
my @drivers = sort keys %{$dbd->drivers};
print wrap("Drivers: ", "\t", join(', ', @drivers)), "\n"
if @drivers;
my @variables = sort keys %{$dbd->variables};
print wrap("Variables: ", "\t", join(', ', @variables)), "\n"
if @variables;
my @registrars = sort keys %{$dbd->registrars};
print wrap("Registrars: ", "\t", join(', ', @registrars)), "\n"
if @registrars;
my @breaktables = sort keys %{$dbd->breaktables};
print wrap("Breaktables: ", "\t", join(', ', @breaktables)), "\n"
if @breaktables;
my %recordtypes = %{$dbd->recordtypes};
if (%recordtypes) {
@rtypes = sort keys %recordtypes;
print wrap("Recordtypes: ", "\t", join(', ', @rtypes)), "\n";
foreach my $rtyp (@rtypes) {
my @devices = $recordtypes{$rtyp}->devices;
print wrap("Devices($rtyp): ", "\t",
join(', ', map {$_->choice} @devices)), "\n"
if @devices;
}
}

252
src/tools/dbdToHtml.pl Normal file
View File

@@ -0,0 +1,252 @@
#!/usr/bin/perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use DBD;
use DBD::Parser;
use EPICS::Getopts;
use EPICS::macLib;
use EPICS::Readfile;
my $tool = 'dbdToHtml';
getopts('DI@o:') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.html] xRecord.dbd\n";
my @path = map { split /[:;]/ } @opt_I;
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
if ($opt_D) { # Output dependencies only
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
exit 0;
}
my $out;
if ($opt_o) {
$out = $opt_o;
} else {
($out = $infile) =~ s/\.dbd$/.html/;
$out =~ s/^.*\///;
$out =~ s/dbCommonRecord/dbCommon/;
}
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
print $out "<h1>$infile</h1>\n";
my $rtypes = $dbd->recordtypes;
my ($rn, $rtyp) = each %{$rtypes};
print $out "<h2>Record Name $rn</h2>\n";
my @fields = $rtyp->fields;
#create a Hash to store the table of field information for each GUI type
%dbdTables = (
"GUI_COMMON" => "",
"GUI_COMMON" => "",
"GUI_ALARMS" => "",
"GUI_BITS1" => "",
"GUI_BITS2" => "",
"GUI_CALC" => "",
"GUI_CLOCK" => "",
"GUI_COMPRESS" => "",
"GUI_CONVERT" => "",
"GUI_DISPLAY" => "",
"GUI_HIST" => "",
"GUI_INPUTS" => "",
"GUI_LINKS" => "",
"GUI_MBB" => "",
"GUI_MOTOR" => "",
"GUI_OUTPUT" => "",
"GUI_PID" => "",
"GUI_PULSE" => "",
"GUI_SELECT" => "",
"GUI_SEQ1" => "",
"GUI_SEQ2" => "",
"GUI_SEQ3" => "",
"GUI_SUB" => "",
"GUI_TIMER" => "",
"GUI_WAVE" => "",
"GUI_SCAN" => "",
"GUI_NONE" => ""
);
#Loop over all of the fields. Build a string that contains the table body
#for each of the GUI Types based on which fields go with which GUI type.
foreach $fVal (@fields) {
my $pg = $fVal->attribute('promptgroup');
while ( ($typ1, $content) = each %dbdTables) {
if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) {
buildTableRow($fVal, $dbdTables{$typ1} );
}
}
}
#Write out each table
while ( ($typ2, $content) = each %dbdTables) {
printHtmlTable($typ2, $content);
}
#add a field to a table body. The specified field and table body are passed
#in as parameters
sub buildTableRow {
my ( $fld, $outStr) = @_;
$longDesc = "&nbsp;";
%htmlCellFmt = (
rowStart => "<tr><td rowspan = \"2\">",
nextCell => "</td><td>",
endRow => "</td></tr>",
nextRow => "<tr><td colspan = \"7\" align=left>"
);
my %cellFmt = %htmlCellFmt;
my $rowStart = $cellFmt{rowStart};
my $nextCell = $cellFmt{nextCell};
my $endRow = $cellFmt{endRow};
my $nextRow = $cellFmt{nextRow};
$outStr = $outStr . $rowStart;
$outStr = $outStr . $fld->name;
$outStr = $outStr . $nextCell;
$outStr = $outStr . $fld->attribute('prompt');
$outStr = $outStr . $nextCell;
my $recType = $fld->dbf_type;
$typStr = $recType;
if ($recType eq "DBF_STRING") {
$typStr = $recType . " [" . $fld->attribute('size') . "]";
}
$outStr = $outStr . $typStr;
$outStr = $outStr . $nextCell;
$outStr = $outStr . design($fld);
$outStr = $outStr . $nextCell;
my $initial = $fld->attribute('initial');
if ( $initial eq '' ) {$initial = "&nbsp;";}
$outStr = $outStr . $initial;
$outStr = $outStr . $nextCell;
$outStr = $outStr . readable($fld);
$outStr = $outStr . $nextCell;
$outStr = $outStr . writable($fld);
$outStr = $outStr . $nextCell;
$outStr = $outStr . processPassive($fld);
$outStr = $outStr . $endRow;
$outStr = $outStr . "\n";
$outStr = $outStr . $nextRow;
$outStr = $outStr . $longDesc;
$outStr = $outStr . $endRow;
$outStr = $outStr . "\n";
$_[1] = $outStr;
}
#Check if the prompt group is defined so that this can be used by clients
sub design {
my $fld = $_[0];
my $pg = $fld->attribute('promptgroup');
if ( $pg eq '' ) {
my $result = 'No';
}
else {
my $result = 'Yes';
}
}
#Check if this field is readable by clients
sub readable {
my $fld = $_[0];
if ( $fld->attribute('special') eq "SPC_DBADDR") {
$return = "Probably";
}
else{
if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
$return = "No";
}
else {
$return = "Yes"
}
}
}
#Check if this field is writable by clients
sub writable {
my $fld = $_[0];
my $spec = $fld->attribute('special');
if ( $spec eq "SPC_NOMOD" ) {
$return = "No";
}
else {
if ( $spec ne "SPC_DBADDR") {
if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
$return = "No";
}
else {
$return = "Yes";
}
}
else {
$return = "Maybe";
}
}
}
#Check to see if the field is process passive on caput
sub processPassive {
my $fld = $_[0];
$pp = $fld->attribute('pp');
if ( $pp eq "YES" or $pp eq "TRUE" ) {
$result = "Yes";
}
elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) {
$result = "No";
}
}
#print the start row to define a table
sub printTableStart {
print $out "<table border =\"1\"> \n";
print $out "<caption><em>$_[0]</em></caption>";
print $out "<th>Field</th>\n";
print $out "<th>Summary</th>\n";
print $out "<th>Type</th>\n";
print $out "<th>DCT</th>\n";
print $out "<th>Default</th>\n";
print $out "<th>Read</th>\n";
print $out "<th>Write</th>\n";
print $out "<th>caPut=PP</th></tr>\n";
}
#print the tail end of the table
sub printTableEnd {
print $out "</table>\n";
}
# Print the table for a GUI type. The name of the GUI type and the Table body
# for this type are fed in as parameters
sub printHtmlTable {
my ($typ2, $content) = $_;
if ( (length $_[1]) gt 0) {
printTableStart($_[0]);
print $out "$_[1]\n";
printTableEnd();
}
}

80
src/tools/dbdToMenuH.pl Executable file
View File

@@ -0,0 +1,80 @@
#!/usr/bin/perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use EPICS::macLib;
use EPICS::Readfile;
my $tool = 'dbdToMenuH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:') or
die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
if ($opt_D) {
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
my $menus = $dbd->menus;
while (my ($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toDeclaration;
}
# FIXME: Where to put metadata for widely used menus?
# In the generated menu.h file is wrong: can't create a list of menu.h files.
# Can only rely on registerRecordDeviceDriver output, so we must require that
# all such menus be named "menu...", and any other menus must be defined in
# the record.dbd file that needs them.
# print OUTFILE "\n#ifdef GEN_MENU_METADATA\n\n";
# while (($name, $menu) = each %{$menus}) {
# print OUTFILE $menu->toDefinition;
# }
# print OUTFILE "\n#endif /* GEN_MENU_METADATA */\n";
print OUTFILE "\n#endif /* $guard_name */\n";
close OUTFILE;
}

231
src/tools/dbdToRecordtypeH.pl Executable file
View File

@@ -0,0 +1,231 @@
#!/usr/bin/perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use EPICS::macLib;
use EPICS::Readfile;
my $tool = 'dbdToRecordtypeH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:s') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
$outfile =~ s/dbCommonRecord/dbCommon/;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
my $rtypes = $dbd->recordtypes;
die "$tool: Input file must contain a single recordtype definition.\n"
unless (1 == keys %{$rtypes});
if ($opt_D) { # Output dependencies only, to stdout
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
our ($rn, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toCdefs;
my @menu_fields = grep {
$_->dbf_type eq 'DBF_MENU'
} $rtyp->fields;
my %menu_used;
grep {
!$menu_used{$_}++
} map {
$_->attribute('menu')
} @menu_fields;
our $menus_defined = $dbd->menus;
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDeclaration;
if ($menu_used{$name}) {
delete $menu_used{$name}
} else {
warn "Menu '$name' defined but not used\n";
}
}
our @menus_external = keys %menu_used;
print OUTFILE $rtyp->toDeclaration;
unless ($rn eq 'dbCommon') {
my $n = 0;
print OUTFILE "typedef enum {\n",
join(",\n",
map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
"\n} ${rn}FieldIndex;\n\n";
print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
if ($opt_s) {
&newtables;
} else {
&oldtables;
}
print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n";
}
print OUTFILE "\n",
"#endif /* $guard_name */\n";
close OUTFILE;
}
sub oldtables {
# Output compatible with R3.14.x
print OUTFILE "#ifdef __cplusplus\n" .
"extern \"C\" {\n" .
"#endif\n" .
"#include <epicsExport.h>\n" .
"static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
"{\n" .
" ${rn}Record *prec = 0;\n" .
join("\n", map {
" prt->papFldDes[${rn}Record" . $_->name . "]->size = " .
"sizeof(prec->" . $_->C_name . ");"
} $rtyp->fields) . "\n" .
join("\n", map {
" prt->papFldDes[${rn}Record" . $_->name . "]->offset = " .
"(char *)&prec->" . $_->C_name . " - (char *)prec;"
} $rtyp->fields) . "\n" .
" prt->rec_size = sizeof(*prec);\n" .
" return 0;\n" .
"}\n" .
"epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" .
"#ifdef __cplusplus\n" .
"}\n" .
"#endif\n";
}
sub newtables {
# Output for an eventual DBD-less IOC
print OUTFILE (map {
"extern const dbMenu ${_}MenuMetaData;\n"
} @menus_external), "\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDefinition;
}
print OUTFILE (map {
"static const char ${rn}FieldName$_\[] = \"$_\";\n" }
$rtyp->field_names), "\n";
my $n = 0;
print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
"static dbFldDes ${rn}FieldMetaData[] = {\n",
join(",\n", map {
my $fn = $_->name;
my $cn = $_->C_name;
" { ${rn}FieldName${fn}," .
$_->dbf_type . ',"' .
$_->attribute('initial') . '",' .
($_->attribute('special') || '0') . ',' .
($_->attribute('pp') || 'FALSE') . ',' .
($_->attribute('interest') || '0') . ',' .
($_->attribute('asl') || 'ASL0') . ',' .
$n++ . ",\n\t\&${rn}RecordMetaData," .
"GEOMETRY_DATA(${rn}Record,$cn) }";
} $rtyp->fields),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record" . $_->name;
} grep {
$_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
} $rtyp->fields),
"\n};\n\n";
my @sorted_names = sort $rtyp->field_names;
print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
join(",\n", map {
" ${rn}FieldName$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "extern rset ${rn}RSET;\n\n",
"static const dbRecordData ${rn}RecordMetaData = {\n",
" \"$rn\",\n",
" sizeof(${rn}Record),\n",
" NELEMENTS(${rn}FieldMetaData),\n",
" ${rn}FieldMetaData,\n",
" ${rn}RecordVAL,\n",
" \&${rn}FieldMetaData[${rn}RecordVAL],\n",
" NELEMENTS(${rn}RecordLinkFieldIndices),\n",
" ${rn}RecordLinkFieldIndices,\n",
" ${rn}RecordSortedFieldNames,\n",
" ${rn}RecordSortedFieldIndices,\n",
" \&${rn}RSET\n",
"};\n\n",
"#ifdef __cplusplus\n",
"extern \"C\" {\n",
"#endif\n\n";
print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
"{\n",
" dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
}
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.pmenu = \n".
" \&" .
$_->attribute('menu') .
"MenuMetaData;\n";
} @menu_fields;
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.base = CT_HEX;\n";
} grep {
$_->attribute('base') eq 'HEX';
} $rtyp->fields;
print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
print OUTFILE " return prt;\n}\n\n",
"#ifdef __cplusplus\n",
"} /* extern \"C\" */\n",
"#endif\n\n";
}

22
src/tools/test/Breaktable.plt Normal file
View File

@@ -0,0 +1,22 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 9;
use DBD::Breaktable;
my $bpt = DBD::Breaktable->new('test');
isa_ok $bpt, 'DBD::Breaktable';
is $bpt->name, 'test', 'Breakpoint table name';
is $bpt->points, 0, 'Points == zero';
$bpt->add_point(0, 0.5);
is $bpt->points, 1, 'First point added';
is_deeply $bpt->point(0), [0, 0.5], 'First point correct';
$bpt->add_point(1, 1.5);
is $bpt->points, 2, 'Second point added';
is_deeply $bpt->point(0), [0, 0.5], 'First point still correct';
is_deeply $bpt->point(1), [1, 1.5], 'Second point correct';
is_deeply $bpt->point(2), undef, 'Third point undefined';

60
src/tools/test/DBD.plt Normal file
View File

@@ -0,0 +1,60 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 18;
use DBD;
my $dbd = DBD->new;
isa_ok $dbd, 'DBD';
is keys %{$dbd->breaktables}, 0, 'No breaktables yet';
my $brk = DBD::Breaktable->new('Brighton');
$dbd->add($brk);
my %brks = %{$dbd->breaktables};
is_deeply \%brks, {Brighton => $brk}, 'Added breaktable';
is keys %{$dbd->drivers}, 0, 'No drivers yet';
my $drv = DBD::Driver->new('Danforth');
$dbd->add($drv);
my %drvs = %{$dbd->drivers};
is_deeply \%drvs, {Danforth => $drv}, 'Added driver';
is keys %{$dbd->functions}, 0, 'No functions yet';
my $fnc = DBD::Function->new('Frank');
$dbd->add($fnc);
my %fncs = %{$dbd->functions};
is_deeply \%fncs, {Frank => $fnc}, 'Added function';
is keys %{$dbd->menus}, 0, 'No menus yet';
my $menu = DBD::Menu->new('Mango');
$dbd->add($menu);
my %menus = %{$dbd->menus};
is_deeply \%menus, {Mango => $menu}, 'Added menu';
is $dbd->menu('Mango'), $menu, 'Named menu';
is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet';
my $rtyp = DBD::Recordtype->new('Rita');
$dbd->add($rtyp);
my %rtypes = %{$dbd->recordtypes};
is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype';
is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype';
is keys %{$dbd->registrars}, 0, 'No registrars yet';
my $reg = DBD::Registrar->new('Reggie');
$dbd->add($reg);
my %regs = %{$dbd->registrars};
is_deeply \%regs, {Reggie => $reg}, 'Added registrar';
is keys %{$dbd->variables}, 0, 'No variables yet';
my $ivar = DBD::Variable->new('IntVar');
my $dvar = DBD::Variable->new('DblVar', 'double');
$dbd->add($ivar);
my %vars = %{$dbd->variables};
is_deeply \%vars, {IntVar => $ivar}, 'First variable';
$dbd->add($dvar);
%vars = %{$dbd->variables};
is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable';

33
src/tools/test/Device.plt Normal file
View File

@@ -0,0 +1,33 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 16;
use DBD::Device;
my $dev = DBD::Device->new('VME_IO', 'test', '"Device"');
isa_ok $dev, 'DBD::Device';
is $dev->name, 'test', 'Device name';
is $dev->link_type, 'VME_IO', 'Link type';
is $dev->choice, 'Device', 'Choice string';
ok $dev->legal_addr('#C0xFEED S123 @xxx'), 'Address legal';
my %dev_addrs = (
CONSTANT => '12345',
PV_LINK => 'Any:Record.NAME CPP.MS',
VME_IO => '# C1 S2 @Anything',
CAMAC_IO => '# B1 C2 N3 A4 F5 @Anything',
RF_IO => '# R1 M2 D3 E4',
AB_IO => '# L1 A2 C3 S4 @Anything',
GPIB_IO => '# L1 A2 @Anything',
BITBUS_IO => '# L1 N2 P3 S4 @Anything',
BBGPIB_IO => '# L1 B2 G3 @Anything',
VXI_IO => '# V1 C2 S3 @Anything',
INST_IO => '@Anything'
);
while (my ($link, $addr) = each(%dev_addrs)) {
$dev->init($link, 'test', '"Device"');
ok $dev->legal_addr($addr), "$link address";
}

13
src/tools/test/Driver.plt Normal file
View File

@@ -0,0 +1,13 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 2;
use DBD::Driver;
my $drv = DBD::Driver->new('test');
isa_ok $drv, 'DBD::Driver';
is $drv->name, 'test', 'Driver name';

13
src/tools/test/Function.plt Normal file
View File

@@ -0,0 +1,13 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 2;
use DBD::Function;
my $func = DBD::Function->new('test');
isa_ok $func, 'DBD::Function';
is $func->name, 'test', 'Function name';

26
src/tools/test/Makefile Normal file
View File

@@ -0,0 +1,26 @@
#*************************************************************************
# 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.
#*************************************************************************
TOP=../../..
include $(TOP)/configure/CONFIG
TESTS += Breaktable
TESTS += DBD
TESTS += Device
TESTS += Driver
TESTS += Function
TESTS += macLib
TESTS += Menu
TESTS += Recfield
TESTS += Recordtype
TESTS += Registrar
TESTS += Variable
TESTSCRIPTS_HOST += $(TESTS:%=%.t)
include $(TOP)/configure/RULES

32
src/tools/test/Menu.plt Normal file
View File

@@ -0,0 +1,32 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 14;
use DBD::Menu;
my $menu = DBD::Menu->new('test');
isa_ok $menu, 'DBD::Menu';
is $menu->name, 'test', 'Menu name';
is $menu->choices, 0, 'Choices == zero';
$menu->add_choice('ch1', '"Choice 1"');
is $menu->choices, 1, 'First choice added';
ok $menu->legal_choice('Choice 1'), 'First choice legal';
is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice found';
$menu->add_choice('ch2', '"Choice 2"');
is $menu->choices, 2, 'Second choice added';
ok $menu->legal_choice('Choice 1'), 'First choice still legal';
is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice still found';
ok $menu->legal_choice('Choice 2'), 'Second choice legal';
is_deeply $menu->choice(1), ['ch2', 'Choice 2'], 'Second choice found';
ok !$menu->legal_choice('Choice 3'), 'Third choice not legal';
is_deeply $menu->choice(2), undef, 'Third choice undefined';
like $menu->toDeclaration, qr/ ^
\s* typedef \s+ enum \s+ {
\s+ ch1 \s+ \/\* [^*]* \*\/,
\s+ ch2 \s+ \/\* [^*]* \*\/,
\s+ test_NUM_CHOICES ,?
\s+ } \s+ test; \s* $ /x, 'C declaration';

114
src/tools/test/Recfield.plt Normal file
View File

@@ -0,0 +1,114 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 76;
use DBD::Recfield;
my $fld_string = DBD::Recfield->new('str', 'DBF_STRING');
isa_ok $fld_string, 'DBD::Recfield';
isa_ok $fld_string, 'DBD::Recfield::DBF_STRING';
$fld_string->set_number(0);
is $fld_string->number, 0, 'Field number';
$fld_string->add_attribute("size", "41");
is keys %{$fld_string->attributes}, 1, "Size set";
ok $fld_string->legal_value("Hello, world!"), 'Legal value';
ok !$fld_string->legal_value("x"x41), 'Illegal string';
$fld_string->check_valid;
like $fld_string->toDeclaration, qr/^\s*char\s+str\[41\];\s*$/, "C declaration";
my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR');
isa_ok $fld_char, 'DBD::Recfield';
isa_ok $fld_char, 'DBD::Recfield::DBF_CHAR';
is $fld_char->name, 'chr', 'Field name';
is $fld_char->dbf_type, 'DBF_CHAR', 'Field type';
ok !$fld_char->legal_value("-129"), 'Illegal - value';
ok $fld_char->legal_value("-128"), 'Legal - value';
ok $fld_char->legal_value("127"), 'Legal + value';
ok !$fld_char->legal_value("0x80"), 'Illegal + hex value';
$fld_char->check_valid;
like $fld_char->toDeclaration, qr/^\s*epicsInt8\s+chr;\s*$/, "C declaration";
my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR');
isa_ok $fld_uchar, 'DBD::Recfield';
isa_ok $fld_uchar, 'DBD::Recfield::DBF_UCHAR';
is $fld_uchar->name, 'uchr', 'Field name';
is $fld_uchar->dbf_type, 'DBF_UCHAR', 'Field type';
ok !$fld_uchar->legal_value("-1"), 'Illegal - value';
ok $fld_uchar->legal_value("0"), 'Legal 0 value';
ok $fld_uchar->legal_value("0377"), 'Legal + value';
ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value';
$fld_uchar->check_valid;
like $fld_uchar->toDeclaration, qr/^\s*epicsUInt8\s+uchr;\s*$/, "C declaration";
my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT');
isa_ok $fld_short, 'DBD::Recfield';
isa_ok $fld_short, 'DBD::Recfield::DBF_SHORT';
is $fld_short->name, 'shrt', 'Field name';
is $fld_short->dbf_type, 'DBF_SHORT', 'Field type';
ok !$fld_short->legal_value("-32769"), 'Illegal - value';
ok $fld_short->legal_value("-32768"), 'Legal - value';
ok $fld_short->legal_value("32767"), 'Legal + value';
ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value';
$fld_short->check_valid;
like $fld_short->toDeclaration, qr/^\s*epicsInt16\s+shrt;\s*$/, "C declaration";
my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT');
isa_ok $fld_ushort, 'DBD::Recfield';
isa_ok $fld_ushort, 'DBD::Recfield::DBF_USHORT';
is $fld_ushort->name, 'ushrt', 'Field name';
is $fld_ushort->dbf_type, 'DBF_USHORT', 'Field type';
ok !$fld_ushort->legal_value("-1"), 'Illegal - value';
ok $fld_ushort->legal_value("0"), 'Legal 0 value';
ok $fld_ushort->legal_value("65535"), 'Legal + value';
ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value';
$fld_ushort->check_valid;
like $fld_ushort->toDeclaration, qr/^\s*epicsUInt16\s+ushrt;\s*$/, "C declaration";
my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG');
isa_ok $fld_long, 'DBD::Recfield';
isa_ok $fld_long, 'DBD::Recfield::DBF_LONG';
is $fld_long->name, 'lng', 'Field name';
is $fld_long->dbf_type, 'DBF_LONG', 'Field type';
ok $fld_long->legal_value("-12345678"), 'Legal - value';
ok $fld_long->legal_value("0x12345678"), 'Legal + value';
ok !$fld_long->legal_value("0xfigure"), 'Illegal value';
$fld_long->check_valid;
like $fld_long->toDeclaration, qr/^\s*epicsInt32\s+lng;\s*$/, "C declaration";
my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG');
isa_ok $fld_ulong, 'DBD::Recfield';
isa_ok $fld_ulong, 'DBD::Recfield::DBF_ULONG';
is $fld_ulong->name, 'ulng', 'Field name';
is $fld_ulong->dbf_type, 'DBF_ULONG', 'Field type';
ok !$fld_ulong->legal_value("-1"), 'Illegal - value';
ok $fld_ulong->legal_value("00"), 'Legal 0 value';
ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value';
ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value';
$fld_ulong->check_valid;
like $fld_ulong->toDeclaration, qr/^\s*epicsUInt32\s+ulng;\s*$/, "C declaration";
my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT');
isa_ok $fld_float, 'DBD::Recfield';
isa_ok $fld_float, 'DBD::Recfield::DBF_FLOAT';
is $fld_float->name, 'flt', 'Field name';
is $fld_float->dbf_type, 'DBF_FLOAT', 'Field type';
ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value';
ok $fld_float->legal_value("0.12345678e9"), 'Legal + value';
ok !$fld_float->legal_value("0x1.5"), 'Illegal value';
$fld_float->check_valid;
like $fld_float->toDeclaration, qr/^\s*epicsFloat32\s+flt;\s*$/, "C declaration";
my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE');
isa_ok $fld_double, 'DBD::Recfield';
isa_ok $fld_double, 'DBD::Recfield::DBF_DOUBLE';
is $fld_double->name, 'dbl', 'Field name';
is $fld_double->dbf_type, 'DBF_DOUBLE', 'Field type';
ok $fld_double->legal_value("-12345e-67"), 'Legal - value';
ok $fld_double->legal_value("12345678e+9"), 'Legal + value';
ok !$fld_double->legal_value("e5"), 'Illegal value';
$fld_double->check_valid;
like $fld_double->toDeclaration, qr/^\s*epicsFloat64\s+dbl;\s*$/, "C declaration";

57
src/tools/test/Recordtype.plt Normal file
View File

@@ -0,0 +1,57 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 17;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Device;
my $rtyp = DBD::Recordtype->new('test');
isa_ok $rtyp, 'DBD::Recordtype';
is $rtyp->name, 'test', 'Record name';
is $rtyp->fields, 0, 'No fields yet';
my $fld1 = DBD::Recfield->new('NAME', 'DBF_STRING');
$fld1->add_attribute("size", "41");
$fld1->check_valid;
my $fld2 = DBD::Recfield->new('DTYP', 'DBF_DEVICE');
$fld2->check_valid;
$rtyp->add_field($fld1);
is $rtyp->fields, 1, 'First field added';
$rtyp->add_field($fld2);
is $rtyp->fields, 2, 'Second field added';
my @fields = $rtyp->fields;
is_deeply \@fields, [$fld1, $fld2], 'Field list';
my @names = $rtyp->field_names;
is_deeply \@names, ['NAME', 'DTYP'], 'Field name list';
is $rtyp->field('NAME'), $fld1, 'Field name lookup';
is $fld1->number, 0, 'Field number 0';
is $fld2->number, 1, 'Field number 1';
is $rtyp->devices, 0, 'No devices yet';
my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device');
$rtyp->add_device($dev1);
is $rtyp->devices, 1, 'First device added';
my @devices = $rtyp->devices;
is_deeply \@devices, [$dev1], 'Device list';
is $rtyp->device('test device'), $dev1, 'Device name lookup';
is $rtyp->cdefs, 0, 'No cdefs yet';
$rtyp->add_cdef("cdef");
is $rtyp->cdefs, 1, 'First cdef added';
my @cdefs = $rtyp->cdefs;
is_deeply \@cdefs, ["cdef"], 'cdef list';

13
src/tools/test/Registrar.plt Normal file
View File

@@ -0,0 +1,13 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 2;
use DBD::Registrar;
my $reg = DBD::Registrar->new('test');
isa_ok $reg, 'DBD::Registrar';
is $reg->name, 'test', 'Registrar name';

15
src/tools/test/Variable.plt Normal file
View File

@@ -0,0 +1,15 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 4;
use DBD::Variable;
my $ivar = DBD::Variable->new('test');
isa_ok $ivar, 'DBD::Variable';
is $ivar->name, 'test', 'Variable name';
is $ivar->var_type, 'int', 'variable defaults to int';
my $dvar = DBD::Variable->new('test', 'double');
is $dvar->var_type, 'double', 'double variable';

72
src/tools/test/macLib.plt Normal file
View File

@@ -0,0 +1,72 @@
#!/usr/bin/perl
use FindBin qw($Bin);
use lib "$Bin/../../../../lib/perl";
use Test::More tests => 34;
use EPICS::macLib;
use Data::Dumper;
my $m = EPICS::macLib->new;
isa_ok $m, 'EPICS::macLib';
is $m->expandString(''), '', 'Empty string';
is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
$m->suppressWarning(1);
is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
$m->putValue('a', 'foo');
is $m->expandString('$(a)'), 'foo', '$(a)';
is $m->expandString('${a}'), 'foo', '${a}';
is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
is $m->expandString('${undef}'), '$(undef)', '${undef} again';
$m->suppressWarning(0);
is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
$m->putValue('b', 'baz');
is $m->expandString('$(b)'), 'baz', '$(b)';
is $m->expandString('$(a)'), 'foo', '$(a)';
is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
$m->putValue('c', '$(a)');
is $m->expandString('$(c)'), 'foo', '$(c)';
is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
$m->putValue('d', 'c');
is $m->expandString('$(d)'), 'c', '$(d)';
is $m->expandString('$($(d))'), 'foo', '$($(d))';
is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
$m->suppressWarning(1);
$m->putValue('c', undef);
is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
$m->installMacros('c=fum,d');
is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
$m->pushScope;
is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
$m->putValue('a', 'grinch');
is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
$m->putValue('b', undef);
is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
$m->popScope;
is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
is $m->expandString('$(b)'), 'baz', '$(b) restored';