OK - so you have some VMS Pascal applications that are important for business.
Maybe you have worked with VMS Pascal for 40 years. Or maybe you are fresh bachelor in computer science right of college being tasked with working with VMS Pascal (possible starting with VMS Pascal for C/Java/C# programmers).
Anyway there is a need to modernize the application a little to integrate better with the rest of the companies IT.This article will show some of the options available for that.
Before modernization there are 4 parts of the solution:
It works, but:
So maybe it could be modernized!
After modernization there are 2 parts of the solution:
Now it is real time processing and the flow is actually simpler.
There are probably not a setup exactly like this anywhere in the world, but there are lots of sites where some of this is happening.
This article will not show an actual example of such a modernized system. This article will just demo some techniques that can be used to build such a modernized system.
JSON and MQ examples will use this data structure.
data.inc:
type
orderline = record
item : varying[32] of char;
qty : unsigned;
price : unsigned; (* cents *)
end;
order = record
id : unsigned;
customer : varying[32] of char;
status : varying [32] of char;
nlines : integer;
line : array [1..100] of orderline;
end;
RESTful web service and database examples will use this data structure:
t1.inc:
const
MAX_ELM = 100;
type
t1 = record
f1 : integer;
f2 : pstr;
end;
t1array = record
nelm : integer;
elm : array [1..MAX_ELM] of t1;
end;
procedure dump(o : t1);
begin
write('(', o.f1:1, ',', o.f2, ')');
end;
procedure dump_one(o : t1);
begin
dump(o);
writeln;
end;
procedure dump_array(a : t1array);
var
i : integer;
begin
for i := 1 to a.nelm do begin
dump(a.elm[i]);
end;
writeln;
end;
Obvious much simpler data in the real world, but it should be sufficient to show the techniques.
If the application is old and it is writing export files or reading import files, then there is a good chance that it is either using fixed width files or CSV files.
Both formats still works fine, but most newer applications will be using XML or JSON as format.
So there can be a need to write and read JSON files.
JSON is not a complex format and it is possible to write JSON manual.
Example of manual write.
writejson_diy.pas:
program writejson_diy(input,output);
%include 'data.inc'
var
o : array [1..3] of order;
i, j : integer;
begin
%include 'init.inc'
writeln('[');
for i := 1 to 3 do begin
writeln(' {');
writeln(' "id": ', o[i].id:1, ',');
writeln(' "customer": "', o[i].customer, '",');
writeln(' "status": "', o[i].status, '",');
writeln(' "orderlines": [');
for j := 1 to o[i].nlines do begin
writeln(' {');
writeln(' "item": "', o[i].line[j].item, '",');
writeln(' "qty": ', o[i].line[j].qty:1, ',');
writeln(' "price": ', (o[i].line[j].price / 100.00):4:2);
if j < o[i].nlines then begin
writeln(' },');
end else begin
writeln(' }');
end;
end;
writeln(' ]');
if i < 3 then begin
writeln(' },');
end else begin
writeln(' }');
end;
end;
writeln(']');
end.
But to prevent mistakes it can be beneficial to use a JSON library.
Example using pJSON library.
writejson_lib.pas:
[inherit('common','pJSON')]
program writejson_lib(input,output);
%include 'data.inc'
var
o : array [1..3] of order;
i, j : integer;
orders, neworder, neworderline, temp : cJSON_ptr;
json : array [1..1000] of pstr;
n : integer;
s : pstr;
begin
%include 'init.inc'
orders := pJSON_CreateArray;
for i := 1 to 3 do begin
neworder := pJSON_CreateObject;
pJSON_AddItemToObject(neworder, 'id', pJSON_CreateNumber(o[i].id));
pJSON_AddItemToObject(neworder, 'customer', pJSON_CreateString(o[i].customer));
pJSON_AddItemToObject(neworder, 'status', pJSON_CreateString(o[i].status));
temp := pJSON_CreateArray;
for j := 1 to o[i].nlines do begin
neworderline := pJSON_CreateObject;
pJSON_AddItemToObject(neworderline, 'item', pJSON_CreateString(o[i].line[j].item));
pJSON_AddItemToObject(neworderline, 'qty', pJSON_CreateNumber(o[i].line[j].qty));
pJSON_AddItemToObject(neworderline, 'price', pJSON_CreateNumber(o[i].line[j].price / 100.00));
pJSON_AddItemReferenceToArray(temp, neworderline);
end;
pJSON_AddItemToObject(neworder, 'orderLines', temp);
pJSON_AddItemReferenceToArray(orders, neworder);
end;
n := pJSON_Print(orders, json);
for i := 1 to n do begin
writeln(json[i]);
end;
pJSON_Delete(orders);
end.
For reading and parsing JSON a library is definitely recommended.
Example using pJSON library.
readjson.pas:
[inherit('common','pJSON')]
program readjson(input, output);
%include 'data.inc'
const
MAX_ORDER = 1000;
type
order_array = array [1..MAX_ORDER] of order;
procedure load(fnm : pstr; var o : order_array; var n : integer);
var
f : text;
json, line : pstr;
orders, oneorder, orderlines, oneorderline: cJSON_ptr;
i, j : integer;
begin
open(f, fnm, old);
reset(f);
json := '';
while not(eof(f)) do begin
readln(f, line);
json := json + line;
end;
close(f);
orders := pJSON_Parse(json);
n := pJSON_GetArraySize(orders);
for i := 1 to n do begin
oneorder := pJSON_GetArrayItem(orders, i - 1);
o[i].id := pJSON_IntValue(pJSON_GetObjectItem(oneorder, 'id'));
o[i].customer := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'customer'));
o[i].status := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'status'));
orderlines := pJSON_GetObjectItem(oneorder, 'orderlines');
o[i].nlines := pJSON_GetArraySize(orderlines);
for j := 1 to o[i].nlines do begin
oneorderline := pJSON_GetArrayItem(orderlines, j - 1);
o[i].line[j].item := pJSON_StringValue(pJSON_GetObjectItem(oneorderline, 'item'));
o[i].line[j].qty := pJSON_IntValue(pJSON_GetObjectItem(oneorderline, 'qty'));
o[i].line[j].price := round(pJSON_DoubleValue(pJSON_GetObjectItem(oneorderline, 'price')) * 100.0);
end;
end;
pJSON_Delete(orders);
end;
procedure dump(o : order_array; n : integer);
var
i, j : integer;
begin
for i := 1 to n do begin
write('id=', o[i].id:1);
write(' customer=', o[i].customer);
writeln(' status=', o[i].status);
for j := 1 to o[i].nlines do begin
write(' item=', o[i].line[j].item);
write(' qty=', o[i].line[j].qty:1);
writeln(' price=', (o[i].line[j].price / 100.00):4:2);
end;
end;
end;
var
o : order_array;
n : integer;
begin
load('diy.json', o, n);
dump(o, n);
load('lib.json', o, n);
dump(o, n);
end.
Web services has been the standard for sync request/response integration for the last 25 years.
Today the fashion dictates RESTful web services with JSON/HTTP(S) as format.
We will test with this example:
Example using phttp library and pJSON library.
t1json.inc:
function parse_one(json : cjSON_ptr) : t1;
var
res : t1;
begin
res.f1 := pJSON_IntValue(pJSON_GetObjectItem(json, 'f1'));
res.f2 := pJSON_StringValue(pJSON_GetObjectItem(json, 'f2'));
parse_one := res;
end;
function parse_array(json : cJSON_ptr) : t1array;
var
res : t1array;
i : integer;
begin
res.nelm := pJSON_GetArraySize(json);
for i := 1 to res.nelm do begin
res.elm[i] := parse_one(pJSON_GetArrayItem(json, i - 1));
end;
parse_array := res;
end;
function format_one(o : t1) : pstr;
var
newt1 : cJSON_ptr;
res : pstr;
begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(o.f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(o.f2));
res := pJSON_PrintUnformatted(newt1);
pJSON_Delete(newt1);
format_one := res;
end;
function format_array(a : t1array) : pstr;
var
newt1array, newt1 : cJSON_ptr;
res : pstr;
i : integer;
begin
newt1array := pJSON_CreateArray;
for i := 1 to a.nelm do begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(a.elm[i].f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(a.elm[i].f2));
pJSON_AddItemReferenceToArray(newt1array, newt1);
end;
res := pJSON_PrintUnformatted(newt1array);
pJSON_Delete(newt1array);
format_array := res;
end;
wscli.pas:
[inherit('common', 'pJSON', 'phttp')]
program wscli(input,output);
%include 't1.inc'
%include 't1json.inc'
procedure testGetOne(host : pstr; port : integer; path : pstr; f1 : integer);
var
con : http;
fullpath, resp : pstr;
json : cJSON_ptr;
o : t1;
begin
writev(fullpath, path, '/t1/', f1:1);
con := http_get(fix(host), port, fix(fullpath), 'application/json');
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
http_recv_all(con, resp.body, resp.length);
http_close(con);
json := pJSON_parse(resp);
o := parse_one(json);
pJSON_Delete(json);
dump_one(o);
end;
procedure testGetAll(host : pstr; port : integer; path : pstr);
var
con : http;
fullpath, resp : pstr;
json : cJSON_ptr;
a : t1array;
begin
writev(fullpath, path, '/t1');
con := http_get(fix(host), port, fix(fullpath), 'application/json');
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
http_recv_all(con, resp.body, resp.length);
http_close(con);
json := pJSON_parse(resp);
a := parse_array(json);
pJSON_Delete(json);
dump_array(a);
end;
procedure testGetSome(host : pstr; port : integer; path : pstr; start_f1, finish_f1 : integer);
var
con : http;
fullpath, resp : pstr;
json : cJSON_ptr;
a : t1array;
begin
writev(fullpath, path, '/t1?start=', start_f1:1, '&finish=', finish_f1:1);
con := http_get(fix(host), port, fix(fullpath), 'application/json');
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
http_recv_all(con, resp.body, resp.length);
http_close(con);
json := pJSON_parse(resp);
a := parse_array(json);
pJSON_Delete(json);
dump_array(a);
end;
procedure testPost(host : pstr; port : integer; path : pstr; o : t1);
var
con : http;
fullpath, resp : pstr;
json : cJSON_ptr;
o2 : t1;
begin
writev(fullpath, path, '/t1');
con := http_post(fix(host), port, fix(fullpath), 'application/json', 'application/json', format_one(o));
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
http_recv_all(con, resp.body, resp.length);
http_close(con);
json := pJSON_parse(resp);
o2 := parse_one(json);
pJSON_Delete(json);
dump_one(o2);
end;
procedure testPut(host : pstr; port : integer; path : pstr; o : t1);
var
con : http;
fullpath : pstr;
begin
writev(fullpath, path, '/t1/', o.f1:1);
con := http_put(fix(host), port, fix(fullpath), 'application/json', format_one(o));
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
writeln(http_txtcode2(con));
http_close(con);
end;
procedure testDelete(host : pstr; port : integer; path : pstr; f1 : integer);
var
con : http;
fullpath : pstr;
begin
writev(fullpath, path, '/t1/', f1:1);
con := http_delete(fix(host), port, fix(fullpath));
if (http_numcode(con) div 100) <> 2 then begin
writeln('HTTP error : ', http_numcode(con):1, ' ', http_txtcode2(con));
end;
writeln(http_txtcode2(con));
http_close(con);
end;
procedure test(host : pstr; port : integer; path : pstr);
var
o : t1;
begin
testGetOne(host, port, path, 123);
testGetAll(host, port, path);
testGetSome(host, port, path, 10, 12);
o.f1 := 123;
o.f2 := 'ABC';
testPost(host, port, path, o);
testPut(host, port, path, o);
testDelete(host, port, path, 123);
end;
begin
test('arnepc5', 81, '/testapi_slim.php');
end.
VMS Pascal is not the optimal language to implement a RESTful service in, but it can be made to work using good old CGI.
CGI is slow and cumbersome, but it is what we have to work with.
Example using pJSON library.
t1json.inc:
function parse_one(json : cjSON_ptr) : t1;
var
res : t1;
begin
res.f1 := pJSON_IntValue(pJSON_GetObjectItem(json, 'f1'));
res.f2 := pJSON_StringValue(pJSON_GetObjectItem(json, 'f2'));
parse_one := res;
end;
function parse_array(json : cJSON_ptr) : t1array;
var
res : t1array;
i : integer;
begin
res.nelm := pJSON_GetArraySize(json);
for i := 1 to res.nelm do begin
res.elm[i] := parse_one(pJSON_GetArrayItem(json, i - 1));
end;
parse_array := res;
end;
function format_one(o : t1) : pstr;
var
newt1 : cJSON_ptr;
res : pstr;
begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(o.f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(o.f2));
res := pJSON_PrintUnformatted(newt1);
pJSON_Delete(newt1);
format_one := res;
end;
function format_array(a : t1array) : pstr;
var
newt1array, newt1 : cJSON_ptr;
res : pstr;
i : integer;
begin
newt1array := pJSON_CreateArray;
for i := 1 to a.nelm do begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(a.elm[i].f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(a.elm[i].f2));
pJSON_AddItemReferenceToArray(newt1array, newt1);
end;
res := pJSON_PrintUnformatted(newt1array);
pJSON_Delete(newt1array);
format_array := res;
end;
testapi.pas:
[inherit('common', 'pJSON', 'sys$library:pascal$lib_routines')]
program testapi(input,output);
%include 't1.inc'
%include 't1json.inc'
procedure get_one(f1 : integer);
var
o : t1;
begin
o.f1 := f1;
o.f2 := 'getOne';
writeln('status: 200 OK');
writeln('content-type: application/json');
writeln;
writeln(format_one(o));
end;
procedure get_all;
var
a : t1array;
begin
a.nelm := 3;
a.elm[1].f1 := 1;
a.elm[1].f2 := 'getAll #1';
a.elm[2].f1 := 2;
a.elm[2].f2 := 'getAll #2';
a.elm[3].f1 := 3;
a.elm[3].f2 := 'getAll #3';
writeln('status: 200 OK');
writeln('content-type: application/json');
writeln;
writeln(format_array(a));
end;
procedure get_some(start_f1, finish_f1 : integer);
var
a : t1array;
i : integer;
begin
a.nelm := finish_f1 - start_f1 + 1;
for i := 1 to a.nelm do begin
a.elm[i].f1 := start_f1 + i - 1;
writev(a.elm[i].f2, 'getSome #', (start_f1 + i - 1):1);
end;
writeln('status: 200 OK');
writeln('content-type: application/json');
writeln;
writeln(format_array(a));
end;
procedure post(o : t1);
begin
writeln('status: 200 OK');
writeln('content-type: application/json');
writeln;
writeln(format_one(o));
end;
procedure put(o : t1);
begin
writeln('status: 204 No Content');
writeln;
writeln('There really is no content here!');
end;
procedure delete(f1 : integer);
begin
writeln('status: 204 No Content');
writeln;
writeln('There really is no content here!');
end;
var
meth, path, qstr, line : pstr;
f1, start_f1, finish_f1, ix : integer;
f : text;
json : cJSON_ptr;
o : t1;
begin
lib$get_symbol('REQUEST_METHOD', meth.body, meth.length);
lib$get_symbol('PATH_INFO', path.body, path.length);
lib$get_symbol('QUERY_STRING', qstr.body, qstr.length);
if meth = 'GET' then begin
if index(path, '/t1/') = 1 then begin
readv(substr(path, 5, length(path) - 4), f1);
get_one(f1);
end else if path = '/t1' then begin
if qstr = '' then begin
get_all;
end else if index(qstr, 'start=') = 1 then begin
ix := index(qstr, '&finish=');
readv(substr(qstr, 7, ix - 7), start_f1);
readv(substr(qstr, ix + 8, length(qstr) - ix - 7), finish_f1);
get_some(start_f1, finish_f1);
end;
end else begin
halt;
end;
end else if meth = 'POST' then begin
open(f, 'apache$input', old);
reset(f);
readln(f, line);
close(f);
json := pJSON_Parse(line);
o := parse_one(json);
pJSON_Delete(json);
post(o);
end else if meth = 'PUT' then begin
open(f, 'apache$input', old);
reset(f);
readln(f, line);
close(f);
json := pJSON_Parse(line);
o := parse_one(json);
pJSON_Delete(json);
put(o);
end else if meth = 'DELETE' then begin
readv(substr(path, 5, length(path) - 4), f1);
delete(f1);
end else begin
halt;
end;
end.
Message queue has been the standard for async push integreation for many years as well.
For whatever reason it has not really caugth on in the VMS world, but it should be used on VMS as well.
Note that ActiveMQ is available for VMS (Alpha, Itanium and x86-64).
Some of the common protocols to talk to message queues are:
We will use STOMP here.
For other languages than Pascal on VMS see here (examples in Java, C, Python, Fortran, Cobol and Basic).
Example using pstomp library.
datajson.inc:
function parse_data(json : pstr; var o : array [low..high:integer] of order) : integer;
var
orders, oneorder, orderlines, oneorderline: cJSON_ptr;
i, j, n : integer;
begin
orders := pJSON_Parse(json);
n := pJSON_GetArraySize(orders);
for i := 1 to n do begin
oneorder := pJSON_GetArrayItem(orders, i - 1);
o[i].id := pJSON_IntValue(pJSON_GetObjectItem(oneorder, 'id'));
o[i].customer := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'customer'));
o[i].status := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'status'));
orderlines := pJSON_GetObjectItem(oneorder, 'orderlines');
o[i].nlines := pJSON_GetArraySize(orderlines);
for j := 1 to o[i].nlines do begin
oneorderline := pJSON_GetArrayItem(orderlines, j - 1);
o[i].line[j].item := pJSON_StringValue(pJSON_GetObjectItem(oneorderline, 'item'));
o[i].line[j].qty := pJSON_IntValue(pJSON_GetObjectItem(oneorderline, 'qty'));
o[i].line[j].price := round(pJSON_DoubleValue(pJSON_GetObjectItem(oneorderline, 'price')) * 100.0);
end;
end;
pJSON_Delete(orders);
parse_data := n;
end;
function format_data(o : array [low..high:integer] of order) : pstr;
var
i, j : integer;
orders, neworder, neworderline, temp : cJSON_ptr;
begin
orders := pJSON_CreateArray;
for i := lower(o) to upper(o) do begin
neworder := pJSON_CreateObject;
pJSON_AddItemToObject(neworder, 'id', pJSON_CreateNumber(o[i].id));
pJSON_AddItemToObject(neworder, 'customer', pJSON_CreateString(o[i].customer));
pJSON_AddItemToObject(neworder, 'status', pJSON_CreateString(o[i].status));
temp := pJSON_CreateArray;
for j := 1 to o[i].nlines do begin
neworderline := pJSON_CreateObject;
pJSON_AddItemToObject(neworderline, 'item', pJSON_CreateString(o[i].line[j].item));
pJSON_AddItemToObject(neworderline, 'qty', pJSON_CreateNumber(o[i].line[j].qty));
pJSON_AddItemToObject(neworderline, 'price', pJSON_CreateNumber(o[i].line[j].price / 100.00));
pJSON_AddItemReferenceToArray(temp, neworderline);
end;
pJSON_AddItemToObject(neworder, 'orderLines', temp);
pJSON_AddItemReferenceToArray(orders, neworder);
end;
format_data := pJSON_PrintUnformatted(orders);
pJSON_Delete(orders);
end;
send.pas:
[inherit('common','pjson','pstomp')]
program send(input,output);
%include 'data.inc'
%include 'datajson.inc'
var
ctx : stomp_ctx;
o : array [1..3] of order;
begin
%include 'init.inc'
stomp_debug(0);
stomp_init(ctx, 'localhost', 61613);
stomp_write(ctx, 'DemoQ', format_data(o));
stomp_write(ctx, 'DemoQ', format_data(o));
stomp_write(ctx, 'DemoQ', format_data(o));
stomp_write(ctx, 'DemoQ', 'quit');
stomp_close(ctx);
end.
Example using pstomp library.
datajson.inc:
function parse_data(json : pstr; var o : array [low..high:integer] of order) : integer;
var
orders, oneorder, orderlines, oneorderline: cJSON_ptr;
i, j, n : integer;
begin
orders := pJSON_Parse(json);
n := pJSON_GetArraySize(orders);
for i := 1 to n do begin
oneorder := pJSON_GetArrayItem(orders, i - 1);
o[i].id := pJSON_IntValue(pJSON_GetObjectItem(oneorder, 'id'));
o[i].customer := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'customer'));
o[i].status := pJSON_StringValue(pJSON_GetObjectItem(oneorder, 'status'));
orderlines := pJSON_GetObjectItem(oneorder, 'orderlines');
o[i].nlines := pJSON_GetArraySize(orderlines);
for j := 1 to o[i].nlines do begin
oneorderline := pJSON_GetArrayItem(orderlines, j - 1);
o[i].line[j].item := pJSON_StringValue(pJSON_GetObjectItem(oneorderline, 'item'));
o[i].line[j].qty := pJSON_IntValue(pJSON_GetObjectItem(oneorderline, 'qty'));
o[i].line[j].price := round(pJSON_DoubleValue(pJSON_GetObjectItem(oneorderline, 'price')) * 100.0);
end;
end;
pJSON_Delete(orders);
parse_data := n;
end;
function format_data(o : array [low..high:integer] of order) : pstr;
var
i, j : integer;
orders, neworder, neworderline, temp : cJSON_ptr;
begin
orders := pJSON_CreateArray;
for i := lower(o) to upper(o) do begin
neworder := pJSON_CreateObject;
pJSON_AddItemToObject(neworder, 'id', pJSON_CreateNumber(o[i].id));
pJSON_AddItemToObject(neworder, 'customer', pJSON_CreateString(o[i].customer));
pJSON_AddItemToObject(neworder, 'status', pJSON_CreateString(o[i].status));
temp := pJSON_CreateArray;
for j := 1 to o[i].nlines do begin
neworderline := pJSON_CreateObject;
pJSON_AddItemToObject(neworderline, 'item', pJSON_CreateString(o[i].line[j].item));
pJSON_AddItemToObject(neworderline, 'qty', pJSON_CreateNumber(o[i].line[j].qty));
pJSON_AddItemToObject(neworderline, 'price', pJSON_CreateNumber(o[i].line[j].price / 100.00));
pJSON_AddItemReferenceToArray(temp, neworderline);
end;
pJSON_AddItemToObject(neworder, 'orderLines', temp);
pJSON_AddItemReferenceToArray(orders, neworder);
end;
format_data := pJSON_PrintUnformatted(orders);
pJSON_Delete(orders);
end;
recv.pas:
[inherit('common','pstomp','pjson')]
program recv(input,output);
%include 'data.inc'
%include 'datajson.inc'
var
ctx : stomp_ctx;
msg : pstr;
msglen : integer;
done : boolean;
o : array [1..100] of order;
i, j, n : integer;
begin
stomp_debug(0);
stomp_init(ctx, 'localhost', 61613);
done := false;
repeat
stomp_read(ctx, 'DemoQ', msg.body, msglen);
if msg.body[msglen] = chr(10) then msglen := msglen - 1;
msg.length := msglen;
if msg = 'quit' then begin
done := true;
end else begin
n := parse_data(msg, o);
for i := 1 to n do begin
write('id=', o[i].id:1);
write(' customer=', o[i].customer);
writeln(' status=', o[i].status);
for j := 1 to o[i].nlines do begin
write(' item=', o[i].line[j].item);
write(' qty=', o[i].line[j].qty:1);
writeln(' price=', (o[i].line[j].price / 100.00):4:2);
end;
end;
end;
until done;
stomp_close(ctx);
end.
Example using pmysql library.
t1json.inc:
function parse_one(json : cjSON_ptr) : t1;
var
res : t1;
begin
res.f1 := pJSON_IntValue(pJSON_GetObjectItem(json, 'f1'));
res.f2 := pJSON_StringValue(pJSON_GetObjectItem(json, 'f2'));
parse_one := res;
end;
function parse_array(json : cJSON_ptr) : t1array;
var
res : t1array;
i : integer;
begin
res.nelm := pJSON_GetArraySize(json);
for i := 1 to res.nelm do begin
res.elm[i] := parse_one(pJSON_GetArrayItem(json, i - 1));
end;
parse_array := res;
end;
function format_one(o : t1) : pstr;
var
newt1 : cJSON_ptr;
res : pstr;
begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(o.f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(o.f2));
res := pJSON_PrintUnformatted(newt1);
pJSON_Delete(newt1);
format_one := res;
end;
function format_array(a : t1array) : pstr;
var
newt1array, newt1 : cJSON_ptr;
res : pstr;
i : integer;
begin
newt1array := pJSON_CreateArray;
for i := 1 to a.nelm do begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(a.elm[i].f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(a.elm[i].f2));
pJSON_AddItemReferenceToArray(newt1array, newt1);
end;
res := pJSON_PrintUnformatted(newt1array);
pJSON_Delete(newt1array);
format_array := res;
end;
dbmysql.pas:
[inherit('common', 'mysql', 'pmysql', 'pmysql2')]
program mysql(input, output);
%include 't1.inc'
procedure checkcon(con : mysql_ptr);
begin
if con = 0 then begin
writeln(pmysql_error(con));
halt;
end;
end;
procedure checkstmt(stmt : mysql_stmt_ptr; con : mysql_ptr);
begin
if stmt = 0 then begin
writeln(pmysql_error(con));
halt;
end;
end;
procedure checkstat(stat : integer; stmt : mysql_stmt_ptr);
begin
if stat <> 0 then begin
writeln(pmysql_stmt_error(stmt));
halt;
end;
end;
function connect(host, un, pw, db : pstr) : mysql_ptr;
var
con : mysql_ptr;
begin
con := pmysql_init;
checkcon(con);
con := pmysql_real_connect(con, host, un, pw, db);
checkcon(con);
connect := con;
end;
function t1_get_one(con : mysql_ptr; f2 : pstr) : integer;
var
stmt : mysql_stmt_ptr;
stat : integer;
inparam : array[1..1] of mysql_bind;
outparam : array[1..1] of mysql_bind;
f1 : integer;
begin
stmt := pmysql_stmt_init(con);
checkstmt(stmt, con);
stat := pmysql_stmt_prepare(stmt, 'SELECT f1 FROM t1 WHERE f2 = ?');
checkstat(stat, stmt);
pmysql_init_bind_string_in(inparam[1], f2);
stat := pmysql_stmt_bind_param(stmt, inparam);
checkstat(stat, stmt);
stat := pmysql_stmt_execute(stmt);
checkstat(stat, stmt);
pmysql_init_bind_long(outparam[1], f1);
stat := pmysql_stmt_bind_result(stmt, outparam);
checkstat(stat, stmt);
stat := pmysql_stmt_store_result(stmt);
checkstat(stat, stmt);
if pmysql_stmt_fetch(stmt) = 0 then begin
t1_get_one := f1;
end else begin
writeln('Row not found');
halt;
end;
pmysql_stmt_free_result(stmt);
end;
function t1_get_all(con : mysql_ptr; var buf : array[$L1..$U1:integer] of t1; bufsiz : integer) : integer;
var
stmt : mysql_stmt_ptr;
stat : integer;
outparam : array[1..2] of mysql_bind;
f1 : integer;
f2 : longpstr(255);
count : integer;
begin
stmt := pmysql_stmt_init(con);
checkstmt(stmt, con);
stat := pmysql_stmt_prepare(stmt, 'SELECT f1,f2 FROM t1');
checkstat(stat, stmt);
stat := pmysql_stmt_execute(stmt);
checkstat(stat, stmt);
pmysql_init_bind_long(outparam[1], f1);
pmysql_init_bind_string_out(outparam[2], f2);
stat := pmysql_stmt_bind_result(stmt, outparam);
checkstat(stat, stmt);
stat := pmysql_stmt_store_result(stmt);
checkstat(stat, stmt);
count := 0;
while pmysql_stmt_fetch(stmt) = 0 do begin
count := count + 1;
buf[count].f1 := f1;
buf[count].f2 := stdstr(f2);
end;
pmysql_stmt_free_result(stmt);
t1_get_all := count;
end;
procedure t1_put(con : mysql_ptr; f1 : integer; f2 : pstr);
var
stmt : mysql_stmt_ptr;
stat : integer;
inparam : array[1..2] of mysql_bind;
begin
stmt := pmysql_stmt_init(con);
checkstmt(stmt, con);
stat := pmysql_stmt_prepare(stmt, 'INSERT INTO t1 VALUES(?, ?)');
checkstat(stat, stmt);
pmysql_init_bind_long(inparam[1], f1);
pmysql_init_bind_string_in(inparam[2], f2);
stat := pmysql_stmt_bind_param(stmt, inparam);
checkstat(stat, stmt);
stat := pmysql_stmt_execute(stmt);
checkstat(stat, stmt);
if pmysql_stmt_affected_rows(stmt) <> 1 then begin
writeln('INSERT did not insert 1 row');
halt;
end;
pmysql_stmt_free_result(stmt);
end;
procedure t1_remove(con : mysql_ptr; f1 : integer);
var
stmt : mysql_stmt_ptr;
stat : integer;
inparam : array[1..1] of mysql_bind;
begin
stmt := pmysql_stmt_init(con);
checkstmt(stmt, con);
stat := pmysql_stmt_prepare(stmt, 'DELETE FROM t1 WHERE f1 = ?');
checkstat(stat, stmt);
pmysql_init_bind_long(inparam[1], f1);
stat := pmysql_stmt_bind_param(stmt, inparam);
checkstat(stat, stmt);
stat := pmysql_stmt_execute(stmt);
checkstat(stat, stmt);
if pmysql_stmt_affected_rows(stmt) <> 1 then begin
writeln('DELETE did not delete 1 row');
halt;
end;
pmysql_stmt_free_result(stmt);
end;
procedure t1_dump(con : mysql_ptr);
const
MAX_REC = 100;
var
buf : array [1..MAX_REC] of t1;
i, n : integer;
begin
n := t1_get_all(con, buf, MAX_REC);
for i := 1 to n do begin
writeln(' ', buf[i].f1:1, ' ', buf[i].f2);
end;
end;
var
con : mysql_ptr;
f1 : integer;
begin
con := connect('localhost', 'root', '', 'test');
f1 := t1_get_one(con, 'BB');
writeln('one:');
writeln(' ', f1:1);
writeln('all:');
t1_dump(con);
t1_put(con, 999, 'XXX');
writeln('all after insert:');
t1_dump(con);
t1_remove(con, 999);
writeln('all after delete:');
t1_dump(con);
pmysql_close(con);
end.
Note that MySQL is not available for VMS x86-64 yet.
SQLRelay for VMS is a VMS client and a Linux/Windows proxy allowing a VMS application to connect to any database that has a Linux/Windows database driver (and that is practically all databases!).
SQLRelay client is open source ported to VMS and available from VSI.
I go through SQLRelay in detail in VMS Tech Demo 2 - SQL Relay.
The Pascal code shown here is almost identical to the Pascal code in that article.
Note that SQLRelay is available for VMS x86-64, but there is a problem with SQLRelay 1.9-3D on VMS x86-64 9.2-3 (fix is promised).
Here we will demo access the following databases:
sqlr.conf:
<?xml version="1.0"?>
<instances>
<instance id="odbcsqlsrv" port="9001" dbase="odbc">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="dsn=ARNEPC5_SQLServer"/>
</connections>
</instance>
<instance id="odbcdb2" port="9002" dbase="odbc">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="dsn=ARNEPC5_DB2;user=arne;password=hemmeligt"/>
</connections>
</instance>
<instance id="localora" port="9003" dbase="oracle">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="oracle_sid=(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = localhost)(PORT = 1521)) (CONNECT_DATA = (SERVER = DEDICATED) (SERVICE_NAME = Test)));user=arne;password=hemmeligt"/>
</connections>
</instance>
<instance id="localdb2" port="9004" dbase="db2" connections="1" maxconnections="1">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="host=localhost;db=Test;user=arne;password=hemmeligt"/>
</connections>
</instance>
<instance id="localmysql" port="9005" dbase="mysql">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="host=localhost;db=Test;user=arne;password=hemmeligt"/>
</connections>
</instance>
<instance id="localpgsql" port="9006" dbase="postgresql">
<users>
<user user="arne" password="topsecret"/>
</users>
<connections>
<connection string="host=localhost;db=Test;user=postgres;password=hemmeligt"/>
</connections>
</instance>
</instances>
sqlrstart.bat:
sqlr-start -config sqlr.conf -id odbcsqlsrv
sqlr-start -config sqlr.conf -id odbcdb2
sqlr-start -config sqlr.conf -id localora
sqlr-start -config sqlr.conf -id localdb2
sqlr-start -config sqlr.conf -id localmysql
sqlr-start -config sqlr.conf -id localpgsql
sqlrstop.bat:
sqlr-stop -config sqlr.conf -id odbcsqlsrv
sqlr-stop -config sqlr.conf -id odbcdb2
sqlr-stop -config sqlr.conf -id localora
sqlr-stop -config sqlr.conf -id localdb2
sqlr-stop -config sqlr.conf -id localmysql
sqlr-stop -config sqlr.conf -id localpgsql
t1json.inc:
function parse_one(json : cjSON_ptr) : t1;
var
res : t1;
begin
res.f1 := pJSON_IntValue(pJSON_GetObjectItem(json, 'f1'));
res.f2 := pJSON_StringValue(pJSON_GetObjectItem(json, 'f2'));
parse_one := res;
end;
function parse_array(json : cJSON_ptr) : t1array;
var
res : t1array;
i : integer;
begin
res.nelm := pJSON_GetArraySize(json);
for i := 1 to res.nelm do begin
res.elm[i] := parse_one(pJSON_GetArrayItem(json, i - 1));
end;
parse_array := res;
end;
function format_one(o : t1) : pstr;
var
newt1 : cJSON_ptr;
res : pstr;
begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(o.f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(o.f2));
res := pJSON_PrintUnformatted(newt1);
pJSON_Delete(newt1);
format_one := res;
end;
function format_array(a : t1array) : pstr;
var
newt1array, newt1 : cJSON_ptr;
res : pstr;
i : integer;
begin
newt1array := pJSON_CreateArray;
for i := 1 to a.nelm do begin
newt1 := pJSON_CreateObject;
pJSON_AddItemToObject(newt1, 'f1', pJSON_CreateNumber(a.elm[i].f1));
pJSON_AddItemToObject(newt1, 'f2', pJSON_CreateString(a.elm[i].f2));
pJSON_AddItemReferenceToArray(newt1array, newt1);
end;
res := pJSON_PrintUnformatted(newt1array);
pJSON_Delete(newt1array);
format_array := res;
end;
dbremote.pas:
[inherit('common')]
program dbremote(input, output);
%include "sqlr$pascal:sqlrdef.pas"
%include 't1.inc'
type
sqlrcon = integer64;
sqlrcurs = integer64;
procedure con_exit(con : sqlrcon);
var
msg : pstr;
begin
sqlr$con_errormessage(con, msg.body, msg.length);
writeln('SQLR connection error: ' + msg);
halt;
end;
procedure curs_exit(curs : sqlrcurs);
var
msg : pstr;
begin
sqlr$cur_errormessage(curs, msg.body, msg.length);
writeln('SQLR cursor error: ' + msg);
halt;
end;
procedure other_exit(msg : pstr);
begin
writeln(msg);
halt;
end;
function t1_get_one(con : sqlrcon;
f2 : pstr;
function ph(num, nam, typ : pstr) : pstr;
function bn(num, nam : pstr) : pstr) : integer;
var
curs : sqlrcurs;
temp : integer64;
stat, res, f1 : integer;
s : pstr;
begin
sqlr$cur_alloc(con, curs);
sqlr$cur_preparequery(curs, 'SELECT f1 FROM t1 WHERE f2 = ' + ph('1', 'f2', 'text'));
sqlr$cur_inputbindstring(curs, bn('1', 'f2'), substr(f2.body, 1, f2.length));
stat := sqlr$cur_executequery(curs, res);
if (stat mod 2) = 0 then curs_exit(curs);
stat := sqlr$cur_getfieldbyindex(curs, 0, 0, s.body, s.length);
if (stat mod 2) = 0 then begin
other_exit('Row not found');
end;
sqlr$cur_getfieldasintbyind(curs, 0, 0, temp);
f1 := temp;
sqlr$con_endsession(con);
sqlr$cur_free(curs);
t1_get_one := f1;
end;
function t1_get_all(con : sqlrcon;
var buf : array[$L1..$U1:integer] of t1;
bufsiz : integer) : integer;
label
done;
var
curs : sqlrcurs;
stat, count : integer;
row : unsigned64;
temp : integer64;
s : pstr;
begin
sqlr$cur_alloc(con, curs);
stat := sqlr$cur_sendquery(curs, 'select f1,f2 from t1');
if (stat mod 2) = 0 then curs_exit(curs);
sqlr$cur_setresultsetbuffersize(curs, 100);
row := 0;
count := 0;
while true do begin
if count >= bufsiz then goto done;
stat := sqlr$cur_getfieldbyindex(curs, row, 0, s.body, s.length);
if (stat mod 2) = 0 then goto done;
count := count + 1;
sqlr$cur_getfieldasintbyind(curs, row, 0, temp);
buf[count].f1 := temp;
sqlr$cur_getfieldbyindex(curs, row, 1, buf[count].f2.body, buf[count].f2.length);
row := row + 1;
end;
done:
sqlr$con_endsession(con);
sqlr$cur_free(curs);
t1_get_all := count;
end;
procedure t1_put(con : sqlrcon;
f1 : integer;
f2 : pstr; function ph(num, nam, typ : pstr) : pstr;
function bn(num, nam : pstr) : pstr);
var
curs : sqlrcurs;
stat, res : integer;
temp : integer64;
n : unsigned64;
begin
sqlr$cur_alloc(con, curs);
sqlr$cur_preparequery(curs, 'INSERT INTO t1 VALUES(' + ph('1', 'f1', 'int') + ', ' + ph('2', 'f2', 'text') + ')');
temp := f1;
sqlr$cur_inputbindlong(curs, bn('1', 'f1'), temp);
sqlr$cur_inputbindstring(curs, bn('2', 'f2'), substr(f2.body, 1, f2.length));
stat := sqlr$cur_executequery(curs, res);
if (stat mod 2) = 0 then curs_exit(curs);
sqlr$cur_affectedrows(curs, n);
if n <> 1 then begin
other_exit('INSERT did not insert 1 row');
end;
sqlr$con_endsession(con);
sqlr$cur_free(curs);
end;
procedure t1_remove(con : sqlrcon;
f1 : integer;
function ph(num, nam, typ : pstr) : pstr;
function bn(num, nam : pstr) : pstr);
var
curs : sqlrcurs;
stat, res : integer;
temp : integer64;
n : unsigned64;
begin
sqlr$cur_alloc(con, curs);
sqlr$cur_preparequery(curs, 'DELETE FROM t1 WHERE f1 = ' + ph('1', 'f1', 'int'));
temp := f1;
sqlr$cur_inputbindlong(curs, bn('1', 'f1'), temp);
stat := sqlr$cur_executequery(curs, res);
if (stat mod 2) = 0 then curs_exit(curs);
sqlr$cur_affectedrows(curs, n);
if n <> 1 then begin
other_exit('DELETE did not delete 1 row');
end;
sqlr$con_endsession(con);
sqlr$cur_free(curs);
end;
procedure t1_dump(con : sqlrcon);
const
MAX_REC = 100;
var
buf : array [1..MAX_REC] of t1;
i, n : integer;
begin
n := t1_get_all(con, buf, MAX_REC);
for i := 1 to n do begin
writeln(' ', buf[i].f1:1, ' ', buf[i].f2);
end;
end;
procedure test(lbl : pstr;
host : pstr;
port : unsigned16;
un : pstr;
pw : pstr;
function ph(num, nam, typ : pstr) : pstr;
function bn(num, nam : pstr) : pstr);
var
con : sqlrcon;
socket : packed array[1..1] of char value '?';
f1 : integer;
begin
writeln('Connect host=', host, ' port=', port:1, ' (', lbl, ')');
sqlr$con_alloc(fix(host), port, socket, fix(un), fix(pw), 0, 1, con);
f1 := t1_get_one(con, 'BB', ph, bn);
writeln('one:');
writeln(' ', f1:1);
writeln('all:');
t1_dump(con);
t1_put(con, 999, 'XXX', ph, bn);
writeln('all after insert:');
t1_dump(con);
t1_remove(con, 999, ph, bn);
writeln('all after delete:');
t1_dump(con);
sqlr$con_free(con);
end;
function std_ph(num, nam, typ : pstr) : pstr;
begin
std_ph := '?';
end;
function std_bn(num, nam : pstr) : pstr;
begin
std_bn := num;
end;
function pgsql_ph(num, nam, typ : pstr) : pstr;
begin
pgsql_ph := '$' + num + '::' + typ;
end;
function pgsql_bn(num, nam : pstr) : pstr;
begin
pgsql_bn := num;
end;
function ora_ph(num, nam, typ : pstr) : pstr;
begin
ora_ph := ':' + nam;
end;
function ora_bn(num, nam : pstr) : pstr;
begin
ora_bn := nam;
end;
begin
test('ODBC - MS SQLServer', 'arnepc5', 9001, 'arne', 'topsecret', std_ph, std_bn);
test('ODBC - IBM DB2', 'arnepc5', 9002, 'arne', 'topsecret', std_ph, std_bn);
test('local - Oracle DB', 'arnepc5', 9003, 'arne', 'topsecret', ora_ph, ora_bn);
test('local - IBM DB2', 'arnepc5', 9004, 'arne', 'topsecret', std_ph, std_bn);
test('local - MySQL', 'arnepc5', 9005, 'arne', 'topsecret', std_ph, std_bn);
test('local - PostgreSQL', 'arnepc5', 9006, 'arne', 'topsecret', pgsql_ph, pgsql_bn);
end.
| Version | Date | Description |
|---|---|---|
| 0.9 | January 7th 2025 | Pre-release |
See list of all articles here
Please send comments to Arne Vajhøj