// Copyright © 1999 by Semaphore Corporation. All rights reserved.
// This code, including modified or derived versions, may not be
// distributed, sold, or incorporated in a product or service for sale,
// without permission from Semaphore Corporation.
interface
uses formats;
procedure initaspi;
procedure ffinitial;
procedure ffnormal;
procedure ffjobstart;
procedure ffjobend(count: longint);
procedure ffendofday;
procedure ffsubmitdetail(const detailrecord: detailrecordtype);
procedure ffdemandanswer(const recidwanted: char8type);
function ffretrieveanswer(const recidwanted: char8type): ffoutputrecordtype;
implementation
uses aspi, windows, sysutils, dialogs;
function codetoname(c: char): string;
begin
case c of
'A': result := 'Demand answer';
'D': result := 'Detail submit';
'E': result := 'Run trailer';
'F': result := 'Job end';
'K': result := 'Ack'; // our madeup code
'O': result := 'Output returned';
'P': result := 'Initial or normal access';
'R': result := 'Run header';
'S': result := 'Job start';
'T': result := 'End of day';
'U': result := 'Test unit ready'; // our madeup code
else result := 'Unknown';
end;
end;
const
scsi_testunitready = $00;
scsi_receive = $08;
scsi_send = $0A;
scsi_inquiry = $12;
var
srb: srb_execscsicmd;
completionevent: thandle;
procedure executescsicommand(codechar: char; bufptr: pointer; bufsize: word);
const
ffdrivenum = 6; // ff black box drive number
cmdlen = 6; // all supported cdb's fill in 6 bytes
begin // execute a scsi send, receive, testunitready, or inquiry command
fillchar(srb, sizeof(srb), char(0)); // sets defaults and our zero adaptor # too
srb.srb_cmd := sc_exec_scsi_cmd;
if (codechar = 'O') or (codechar = 'K') then // read black box output or ack
begin
srb.cdbbyte[0] := scsi_receive;
srb.srb_flags := srb_dir_in;
end
else if codechar = 'U' then // test unit ready
srb.cdbbyte[0] := scsi_testunitready // no dir flags
else if codechar = 'W' then // inquiry
begin
srb.cdbbyte[0] := scsi_inquiry;
srb.srb_flags := srb_dir_in;
end
else // assume an output command
begin
srb.cdbbyte[0] := scsi_send;
srb.srb_flags := srb_dir_out;
end;
srb.cdbbyte[3] := hibyte(bufsize);
srb.cdbbyte[4] := lobyte(bufsize);
srb.srb_flags := srb.srb_flags or srb_event_notify;
srb.srb_target := ffdrivenum;
srb.srb_buflen := bufsize;
srb.srb_bufpointer := bufptr;
srb.srb_senselen := sense_len;
srb.srb_cdblen := cmdlen;
srb.srb_postproc := pointer(completionevent);
resetevent(completionevent);
sendaspi32command(@srb);
if srb.srb_status = ss_pending then
waitforsingleobject(completionevent, infinite);
end;
procedure waitunitready;
var start: longint;
begin
start := gettickcount;
repeat
executescsicommand('U', nil, 0); // test unit ready
if srb.srb_status = ss_comp then exit; // unit ready
until (gettickcount - start) > 5000; // allow 5 secs
showmessage('wait unit ready timed out');
end;
procedure executecommand(codechar: char; bufptr: pointer; bufsize: word);
begin
waitunitready;
executescsicommand(codechar, bufptr, bufsize);
if srb.srb_status <> ss_comp then
showmessage(codetoname(codechar) + ' error = ' + inttohex(srb.srb_status, 2)
+ ' hastat = ' + inttohex(srb.srb_hastat, 2)
+ ' targstat = ' + inttohex(srb.srb_targstat, 2));
end;
procedure executeandack(codechar: char; bufptr: pointer; bufsize: word);
begin // execute a scsi command and wait for an ack
executecommand(codechar, bufptr, bufsize); // get ack too
ackrecord.error := 'xxx'; // to make sure we don't see junk
executecommand('K', @ackrecord, sizeof(ackrecord)); // retrieve ack
if ackrecord.error <> '000' then
showmessage('ACK error ' + ackrecord.error + ' for ' + codetoname(codechar));
end;
procedure initaspi;
var
inquiryresult: packed record
byte0, byte1, byte2, byte3: byte;
extradatalength: byte;
reserved: word;
byte7: byte;
vendorid: char8type;
productid: array[16..31] of char;
productrev: array[32..35] of char;
infostring: array[36..55] of char;
end;
begin // initialize the aspi interface
completionevent := createevent(nil, true, false, nil); // destroyed when we quit
if completionevent = 0 then showmessage('Event creation failed!');
if hibyte(loword(GetASPI32SupportInfo)) = ss_comp then
begin
executecommand('W', @inquiryresult, sizeof(inquiryresult)); // inquiry
showmessage(inquiryresult.vendorid + ' ' + inquiryresult.productid + ' '
+ inquiryresult.productrev + ' ' + inquiryresult.infostring);
end
else showmessage('Can''t initialize ASPI!');
end;
var accessrecord: packed record // per the black box interface
id: char;
atype: char;
password: char28type;
filler1: char;
mlc: char;
filler2: array[1..480] of byte;
end;
procedure savereturnedpassword(pwd: string); external 'your.dll';
procedure ffinitial;
begin // request initial black box access
accessrecord.id := 'P';
accessrecord.atype := 'I';
accessrecord.password := 'INITIAL.28.CHARACTER.PASSWRD';
accessrecord.mlc := 'C';
executeandack('P', @accessrecord, sizeof(accessrecord));
if ackrecord.error = '000' then savereturnedpassword(ackrecord.password);
end;
function retrievesavedpassword: string; external 'your.dll';
procedure ffnormal;
begin // request normal black box access
accessrecord.id := 'P';
accessrecord.atype := 'N';
copyfixed(@accessrecord.password, retrievesavedpassword, sizeof(accessrecord.password));
accessrecord.mlc := 'C';
executeandack('P', @accessrecord, sizeof(accessrecord));
if ackrecord.error = '000' then savereturnedpassword(ackrecord.password);
end;
function guibuttonchecked: boolean; external 'your.dll';
procedure ffjobstart;
var
currentdatetime: tdatetime;
jobrecord: packed record
id: char;
platform: platformtype;
date, time: char8type;
filler: array[1..477] of char;
end;
runrecord: packed record
id: char;
platform: platformtype;
customer: char8type;
filler1: array[1..13] of char;
logic: char;
filler2: array[1..471] of char;
end;
begin // start a black box job
jobrecord.id := 'S';
copyfixed(@jobrecord.platform, customerid, sizeof(jobrecord.platform));
currentdatetime := now;
copyfixed(@jobrecord.date, formatdatetime('yyyymmdd', currentdatetime), sizeof(jobrecord.date));
copyfixed(@jobrecord.time, formatdatetime('hhmmss', currentdatetime) + '00', sizeof(jobrecord.time));
executeandack('S', @jobrecord, sizeof(jobrecord)); // job start
runrecord.id := 'R';
runrecord.platform := jobrecord.platform;
copyfixed(@runrecord.customer, customerid, sizeof(runrecord.customer));
if guibuttonchecked then runrecord.logic := 'I' // optional individual
else runrecord.logic := ' '; // standard family
executeandack('R', @runrecord, sizeof(runrecord)); // run header
end;
procedure ffjobend(count: longint);
var trailerrecord, jobendrecord: packed record
id: char;
platform: platformtype;
total: char8type;
filler: array[1..485] of char;
end;
begin // stop a black box job
trailerrecord.id := 'E';
copyfixed(@trailerrecord.platform, customerid, sizeof(trailerrecord.platform));
copyfixed(@trailerrecord.total, inttostr(count), sizeof(trailerrecord.total));
executeandack('E', @trailerrecord, sizeof(trailerrecord)); // run trailer
jobendrecord.id := 'F';
jobendrecord.platform := trailerrecord.platform;
jobendrecord.total := trailerrecord.total;
executeandack('F', @jobendrecord, sizeof(jobendrecord)); // job end
end;
procedure ffendofday;
var enddayrecord: packed record
id: char;
filler: array[1..511] of char;
end;
begin // declare end-of-day to black box
enddayrecord.id := 'T';
executeandack('T', @enddayrecord, sizeof(enddayrecord)); // end of day
end;
procedure ffsubmitdetail(const detailrecord: detailrecordtype);
begin // start black box working on a record
executecommand('D', @detailrecord, sizeof(detailrecord)); // submit detail
end;
procedure ffdemandanswer(const recidwanted: char8type);
var demandrecord: packed record
id: char;
platform: platformtype;
recid: char8type;
filler: array[1..485] of char;
end;
begin // ask black box for a change-of-address
demandrecord.id := 'A';
copyfixed(@demandrecord.platform, customerid, sizeof(demandrecord.platform));
demandrecord.recid := recidwanted;
executecommand('A', @demandrecord, sizeof(demandrecord)); // demand answer
end;
function ffretrieveanswer(const recidwanted: char8type): ffoutputrecordtype;
var start: longint; stuck: boolean;
begin // ask black box for a change-of-address
stuck := false; // not necessary, just satisfy compiler
start := gettickcount;
repeat
executecommand('O', @result, sizeof(result)); // retrieve output
if result.response = 'Y' then exit
else if result.response = 'N' then exit
else // assume 'T' for timeout
begin
stuck := (gettickcount - start) > 2000; // 2 secs
if not stuck then // make black box start over
begin
ffdemandanswer(recidwanted);
sleep(10);
end;
end;
until stuck;
fillchar(result, sizeof(result), ' ');
result.response := 'N';
end;
end.