>>SOURCE FORMAT IS FIXED ****************************************************************** * Author: Brian Tiffin * Date: August 2008 * Purpose: Demonstration of OpenCOBOL message queues * Tectonics: gcc -c ocmq.c * cobc -Wall -x -lrt mqserver.cob ocmq.o ****************************************************************** identification division. program-id. mqserver. data division. working-storage section. * Constants for the Open Flags 01 MQO-RDONLY constant as 0. 01 MQO-WRONLY constant as 1. 01 MQO-RDWR constant as 2. 01 MQO-CREAT constant as 64. 01 MQO-EXCL constant as 128. 01 MQO-NONBLOCK constant as 2048. * Constants for the protection/permission bits 01 MQS-IREAD constant as 256. 01 MQS-IWRITE constant as 128. * Need a better way of displaying newlines 01 newline pic x value x'0a'. * Need a better way to handle verbosity 01 verbosity pic 9 value 1. 88 verbose value 1. * Message Queues return an ID, maps to int 01 mqid usage binary-long. 01 mqres usage binary-long. * Queue names end up in an mqueue virtual filesystem on GNU/Linux 01 mqname. 02 name-display pic x(5) value "/ocmq". 02 filler pic x value x'00'. 01 mqopenflags usage binary-long. 01 mqpermissions usage binary-long. * Place name of MQNOTIFY OpenCOBOL signal handler procedure here * NOT YET IMPLEMENTED. ocmq assumes hardcoded MQPROCESSOR 01 mqprocedure. 02 procedure-name pic x(11) value "MQPROCESSOR". 02 filler pic x value low-value. 01 default-message pic x(20) value 'OpenCOBOL is awesome'. 01 user-message pic x(80). 01 send-length usage binary-long. 01 urgent-message pic x(20) value 'Urgent OpenCOBOL msg'. * Data members for access to C global errno and error strings 01 errnumber usage binary-long. 01 errstr pic x(256). * legend to use with the error reporting 01 operation pic x(7). * Setup a waiting loop for 9 one minute intervals 01 loopy pic 9. * Debian GNU/Linux defaults to Message Queue entry limit of 8K 01 msgbuf pic x(8192). 01 msglen usage binary-long value 8192. * Priorities range from 0 to 31 on many systems, can be more 01 msgprio usage binary-long. * MQ attributes. See /usr/include/bits/mqueue.h 01 mqattr. 03 mqflags usage binary-long. 03 mqmaxmsg usage binary-long. 03 mqmsgsize usage binary-long. 03 mqcurmsqs usage binary-long. 03 filler usage binary-long occurs 4 times. 01 oldattr. 03 mqflags usage binary-long. 03 mqmaxmsg usage binary-long. 03 mqmsgsize usage binary-long. 03 mqcurmsqs usage binary-long. 03 filler usage binary-long occurs 4 times. procedure division. * The ocmq API support MQCREATE and MQOPEN. * This example uses non blocking, non exclusive create * read/write by owner and default attributes compute mqopenflags = MQO-RDWR + MQO-CREAT + MQO-NONBLOCK end-compute. compute mqpermissions = MQS-IREAD + MQS-IWRITE end-compute. * Sample shows the two types of open, but only evaluates create if zero = zero call "MQCREATE" using mqname by value mqopenflags by value mqpermissions by value 0 returning mqid end-call else call "MQOPEN" using mqname by value mqopenflags returning mqid end-call end-if. move "create" to operation. perform show-error. * Show the attributes after initial create if verbose perform show-attributes end-if. * Register notification call "MQNOTIFY" using by value mqid by reference mqprocedure returning mqres end-call. move "notify" to operation. perform show-error. * Main sleeper loop. Expectation is to awake on NOTIFY signal * In this example, sleep in 1 minute intervals, looping 8 times perform varying loopy from 1 by 1 until loopy > 8 display "Waiting... " loopy end-display call "CBL_OC_NANOSLEEP" using 60000000000 returning mqres end-call end-perform. * Close the queue. When unlinked, it will be removed call "MQCLOSE" using by value mqid returning mqres end-call. move "close" to operation. perform show-error. * Will be removed on last close, but no new opens allowed call "MQUNLINK" using mqname returning mqres end-call. move "unlink" to operation. perform show-error. goback. ****************************************************************** * Information display of the Message Queue attributes. show-attributes. call "MQGETATTR" using by value mqid by reference mqattr returning mqres end-call move "getattr" to operation. perform show-error. * Display the message queue attributes display name-display " attributes:" newline "flags: " mqflags of mqattr newline "max msgs: " mqmaxmsg of mqattr newline "msg size: " mqmsgsize of mqattr newline "cur msgs: " mqcurmsqs of mqattr end-display . * The C global errno error display paragraph show-error. call "ERRORNUMBER" returning mqres end-call if mqres > 0 display operation " errno: " mqres end-display call "ERRORSTRING" using errstr by value length errstr returning mqres end-call if mqres > 0 display " strerror: " errstr(1:mqres) end-display end-if end-if . end program mqserver. ****************************************************************** * Author: Brian Tiffin * Date: August 2008 * Purpose: Demonstration of OpenCOBOL message queue notification * Tectonics: See mqserver above. * NOTE: The procedure MQPROCESSOR is hardcoded * in ocmq, in the ocmq_handler signal function ****************************************************************** identification division. program-id. MQPROCESSOR. data division. working-storage section. 01 msgbuf pic x(8192). 01 msglen usage binary-long value 8192. 01 msgprio usage binary-long. 01 mqres usage binary-long. linkage section. 01 mqid usage binary-long. * This procedure is called from within an mq_notify signal * handler, and the MQPROCESSOR module name is hard coded * in ocmq.c procedure division using mqid. * Pull all messages from queue, * highest priority message will pull off first perform with test after until mqres <= 0 call "MQRECEIVE" using by value mqid by reference msgbuf by value msglen by reference msgprio returning mqres end-call if mqres > 0 display "recieve len: " mqres " prio: " msgprio end-display display "message: " msgbuf(1:mqres) end-display end-if * move "receive" to operation * perform show-error end-perform. goback. end program MQPROCESSOR.