diff --git a/configure/CONFIG_BASE b/configure/CONFIG_BASE index e88e1e80d..5b5319b2c 100644 --- a/configure/CONFIG_BASE +++ b/configure/CONFIG_BASE @@ -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 diff --git a/configure/RULES.Db b/configure/RULES.Db index 27b3092d7..d63ca9f1a 100644 --- a/configure/RULES.Db +++ b/configure/RULES.Db @@ -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 diff --git a/src/Makefile b/src/Makefile index 88a03d7c6..ad00bc90b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -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 diff --git a/src/ioc/db/RULES b/src/ioc/db/RULES index 7b6f1d9ae..951123ca4 100644 --- a/src/ioc/db/RULES +++ b/src/ioc/db/RULES @@ -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) - diff --git a/src/ioc/db/dbCommon.dbd b/src/ioc/db/dbCommon.dbd index eb8e7bf35..29d1c0009 100644 --- a/src/ioc/db/dbCommon.dbd +++ b/src/ioc/db/dbCommon.dbd @@ -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") diff --git a/src/ioc/dbStatic/Makefile b/src/ioc/dbStatic/Makefile index 6b2d16840..c2f642bb1 100644 --- a/src/ioc/dbStatic/Makefile +++ b/src/ioc/dbStatic/Makefile @@ -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 diff --git a/src/ioc/dbStatic/dbExpand.c b/src/ioc/dbStatic/dbExpand.c deleted file mode 100644 index 5fac686d3..000000000 --- a/src/ioc/dbStatic/dbExpand.c +++ /dev/null @@ -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 -#include -#include -#include - -#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; -} diff --git a/src/ioc/dbStatic/dbReadTest.c b/src/ioc/dbStatic/dbReadTest.c deleted file mode 100644 index c7a433232..000000000 --- a/src/ioc/dbStatic/dbReadTest.c +++ /dev/null @@ -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 -#include -#include -#include - -#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 = ⊂ - 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; ipgpHash); - dbDumpMenu(pdbbase,NULL); - dbDumpRecord(pdbbase,NULL,0); - dbReportDeviceConfig(pdbbase,stdout); -*/ - dbFreeBase(pdbbase); - return(0); -} diff --git a/src/ioc/dbStatic/dbToMenuH.c b/src/ioc/dbStatic/dbToMenuH.c deleted file mode 100644 index e910d1a78..000000000 --- a/src/ioc/dbStatic/dbToMenuH.c +++ /dev/null @@ -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 -#include -#include -#include - -#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 = ⊂ - 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; iignoreMissingMenus = 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; inChoice; 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); -} diff --git a/src/ioc/dbStatic/dbToRecordtypeH.c b/src/ioc/dbStatic/dbToRecordtypeH.c deleted file mode 100644 index a97a44f87..000000000 --- a/src/ioc/dbStatic/dbToRecordtypeH.c +++ /dev/null @@ -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 -#include -#include -#include -#include - -#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 = ⊂ - 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; iignoreMissingMenus = 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; inChoice; 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; ino_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; ino_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 \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; ino_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); -} diff --git a/src/ioc/registry/registerRecordDeviceDriver.pl b/src/ioc/registry/registerRecordDeviceDriver.pl index 3fa64cbe3..3adda373a 100755 --- a/src/ioc/registry/registerRecordDeviceDriver.pl +++ b/src/ioc/registry/registerRecordDeviceDriver.pl @@ -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() { - 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] = - {®isterRecordDeviceDriverArg0}; -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(®isterRecordDeviceDriverFuncDef, - registerRecordDeviceDriverCallFunc); + iocshRegister(&rrddFuncDef, rrddCallFunc); return 0; } diff --git a/src/tools/DBD.pm b/src/tools/DBD.pm new file mode 100644 index 000000000..edc403811 --- /dev/null +++ b/src/tools/DBD.pm @@ -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; diff --git a/src/tools/DBD/Base.pm b/src/tools/DBD/Base.pm new file mode 100644 index 000000000..b6ac2d724 --- /dev/null +++ b/src/tools/DBD/Base.pm @@ -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; diff --git a/src/tools/DBD/Breaktable.pm b/src/tools/DBD/Breaktable.pm new file mode 100644 index 000000000..5199d61fb --- /dev/null +++ b/src/tools/DBD/Breaktable.pm @@ -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; diff --git a/src/tools/DBD/Device.pm b/src/tools/DBD/Device.pm new file mode 100644 index 000000000..f439c6d86 --- /dev/null +++ b/src/tools/DBD/Device.pm @@ -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; diff --git a/src/tools/DBD/Driver.pm b/src/tools/DBD/Driver.pm new file mode 100644 index 000000000..7eedcdf8d --- /dev/null +++ b/src/tools/DBD/Driver.pm @@ -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; diff --git a/src/tools/DBD/Function.pm b/src/tools/DBD/Function.pm new file mode 100644 index 000000000..51e17d8aa --- /dev/null +++ b/src/tools/DBD/Function.pm @@ -0,0 +1,10 @@ +package DBD::Function; +use DBD::Base; +@ISA = qw(DBD::Base); + +sub init { + return shift->SUPER::init(shift, "function name"); +} + +1; + diff --git a/src/tools/DBD/Menu.pm b/src/tools/DBD/Menu.pm new file mode 100644 index 000000000..ec59e8567 --- /dev/null +++ b/src/tools/DBD/Menu.pm @@ -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; diff --git a/src/tools/DBD/Output.pm b/src/tools/DBD/Output.pm new file mode 100644 index 000000000..c373a3683 --- /dev/null +++ b/src/tools/DBD/Output.pm @@ -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; diff --git a/src/tools/DBD/Parser.pm b/src/tools/DBD/Parser.pm new file mode 100644 index 000000000..11af4df76 --- /dev/null +++ b/src/tools/DBD/Parser.pm @@ -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; diff --git a/src/tools/DBD/Recfield.pm b/src/tools/DBD/Recfield.pm new file mode 100644 index 000000000..259af0eb6 --- /dev/null +++ b/src/tools/DBD/Recfield.pm @@ -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; diff --git a/src/tools/DBD/Recordtype.pm b/src/tools/DBD/Recordtype.pm new file mode 100644 index 000000000..f6571b7e0 --- /dev/null +++ b/src/tools/DBD/Recordtype.pm @@ -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; diff --git a/src/tools/DBD/Registrar.pm b/src/tools/DBD/Registrar.pm new file mode 100644 index 000000000..b4692c596 --- /dev/null +++ b/src/tools/DBD/Registrar.pm @@ -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; + diff --git a/src/tools/DBD/Variable.pm b/src/tools/DBD/Variable.pm new file mode 100644 index 000000000..8d02d64cd --- /dev/null +++ b/src/tools/DBD/Variable.pm @@ -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; diff --git a/src/tools/EPICS/Readfile.pm b/src/tools/EPICS/Readfile.pm new file mode 100644 index 000000000..43ee493f4 --- /dev/null +++ b/src/tools/EPICS/Readfile.pm @@ -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, ; + 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; diff --git a/src/tools/EPICS/macLib.pm b/src/tools/EPICS/macLib.pm new file mode 100644 index 000000000..332ceca67 --- /dev/null +++ b/src/tools/EPICS/macLib.pm @@ -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; diff --git a/src/tools/Makefile b/src/tools/Makefile index 4dfc7aa1d..8d306f4e8 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -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 diff --git a/src/tools/dbdExpand.pl b/src/tools/dbdExpand.pl new file mode 100755 index 000000000..2335cbddd --- /dev/null +++ b/src/tools/dbdExpand.pl @@ -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; diff --git a/src/tools/dbdReport.pl b/src/tools/dbdReport.pl new file mode 100755 index 000000000..303782879 --- /dev/null +++ b/src/tools/dbdReport.pl @@ -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; + } +} diff --git a/src/tools/dbdToHtml.pl b/src/tools/dbdToHtml.pl new file mode 100644 index 000000000..936cbf48c --- /dev/null +++ b/src/tools/dbdToHtml.pl @@ -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 "

$infile

\n"; + +my $rtypes = $dbd->recordtypes; + +my ($rn, $rtyp) = each %{$rtypes}; +print $out "

Record Name $rn

\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 = " "; + %htmlCellFmt = ( + rowStart => "", + nextCell => "", + endRow => "", + nextRow => "" + ); + 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 = " ";} + $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 " \n"; + print $out ""; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + +} + +#print the tail end of the table +sub printTableEnd { + print $out "
$_[0]
FieldSummaryTypeDCTDefaultReadWritecaPut=PP
\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(); + } + +} diff --git a/src/tools/dbdToMenuH.pl b/src/tools/dbdToMenuH.pl new file mode 100755 index 000000000..1e5f35fb2 --- /dev/null +++ b/src/tools/dbdToMenuH.pl @@ -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; +} diff --git a/src/tools/dbdToRecordtypeH.pl b/src/tools/dbdToRecordtypeH.pl new file mode 100755 index 000000000..06d1dd0cc --- /dev/null +++ b/src/tools/dbdToRecordtypeH.pl @@ -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 \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"; +} diff --git a/src/tools/test/Breaktable.plt b/src/tools/test/Breaktable.plt new file mode 100644 index 000000000..36085d331 --- /dev/null +++ b/src/tools/test/Breaktable.plt @@ -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'; + diff --git a/src/tools/test/DBD.plt b/src/tools/test/DBD.plt new file mode 100644 index 000000000..d6e5676da --- /dev/null +++ b/src/tools/test/DBD.plt @@ -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'; + diff --git a/src/tools/test/Device.plt b/src/tools/test/Device.plt new file mode 100644 index 000000000..d362054c2 --- /dev/null +++ b/src/tools/test/Device.plt @@ -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"; +} + diff --git a/src/tools/test/Driver.plt b/src/tools/test/Driver.plt new file mode 100644 index 000000000..f78c66da9 --- /dev/null +++ b/src/tools/test/Driver.plt @@ -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'; + diff --git a/src/tools/test/Function.plt b/src/tools/test/Function.plt new file mode 100644 index 000000000..6eb124fa8 --- /dev/null +++ b/src/tools/test/Function.plt @@ -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'; + diff --git a/src/tools/test/Makefile b/src/tools/test/Makefile new file mode 100644 index 000000000..b0864e38a --- /dev/null +++ b/src/tools/test/Makefile @@ -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 + diff --git a/src/tools/test/Menu.plt b/src/tools/test/Menu.plt new file mode 100644 index 000000000..f8da94b97 --- /dev/null +++ b/src/tools/test/Menu.plt @@ -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'; diff --git a/src/tools/test/Recfield.plt b/src/tools/test/Recfield.plt new file mode 100644 index 000000000..bf92ea83d --- /dev/null +++ b/src/tools/test/Recfield.plt @@ -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"; + diff --git a/src/tools/test/Recordtype.plt b/src/tools/test/Recordtype.plt new file mode 100644 index 000000000..1c829ae49 --- /dev/null +++ b/src/tools/test/Recordtype.plt @@ -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'; diff --git a/src/tools/test/Registrar.plt b/src/tools/test/Registrar.plt new file mode 100644 index 000000000..2c203c016 --- /dev/null +++ b/src/tools/test/Registrar.plt @@ -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'; + diff --git a/src/tools/test/Variable.plt b/src/tools/test/Variable.plt new file mode 100644 index 000000000..c8a1a023d --- /dev/null +++ b/src/tools/test/Variable.plt @@ -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'; diff --git a/src/tools/test/macLib.plt b/src/tools/test/macLib.plt new file mode 100644 index 000000000..b0c987818 --- /dev/null +++ b/src/tools/test/macLib.plt @@ -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'; +