app/baisy/2.2.1-schulis/src/get put interface.dos

Raw file
Back to index

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
PACKET dosgetputDEFINES logmodus,opendosdisk,closedosdisk,accessdosdisk,
openfetchdosfile,closefetchdosfile,catnextfetchdoscluster,
readnextfetchdoscluster,waslastfetchcluster,opensavedosfile,
writenextsavedoscluster,closesavedosfile,erasedosfile,alldosfiles,
alldossubdirs,dosfileexists,doslist,cleardosdisk,formatdosdisk:BOOL VAR 
logflag:=FALSE ;PROC logmodus(BOOL CONST status):logflag:=statusEND PROC 
logmodus;LET maxclustersize=8192,realspersector=64;LET CLUSTER =BOUND STRUCT 
(ALIGN dummy,ROW maxclustersizeREAL clusterrow);CLUSTER VAR cluster;
DATASPACE VAR clusterds;INITFLAG VAR clusterdsused:=FALSE ;TEXT VAR 
convertbuffer;INT VAR convertbufferlength;PROC initclusterhandle:IF 
initialized(clusterdsused)THEN forget(clusterds)FI ;clusterds:=nilspace;
cluster:=clusterds;convertbuffer:="";convertbufferlength:=0.END PROC 
initclusterhandle;PROC catclustertext(REAL CONST clusterno,TEXT VAR 
destination,INT CONST to):readdiskcluster(clusterds,2,clusterno);
initconvertbuffer;INT VAR i;FOR iFROM 1UPTO sectorspercluster*realspersector
REP replace(convertbuffer,i,cluster.clusterrow[i])PER ;destinationCAT subtext
(convertbuffer,1,to).initconvertbuffer:IF convertbufferlength<clustersize
THEN convertbufferCAT (clustersize-convertbufferlength)*"*";
convertbufferlength:=clustersizeFI .END PROC catclustertext;PROC 
writetexttocluster(REAL CONST clusterno,TEXT CONST string):IF LENGTH string<
clustersizeTHEN executewritetext(text(string,clustersize))ELSE 
executewritetext(string)FI ;writediskcluster(clusterds,2,clusterno).END PROC 
writetexttocluster;PROC executewritetext(TEXT CONST string):INT VAR i;FOR i
FROM 1UPTO sectorspercluster*realspersectorREP cluster.clusterrow[i]:=string
RSUB iPER .END PROC executewritetext;BOOL VAR diskopen:=FALSE ;TEXT VAR 
actpath;REAL VAR lastaccesstime;PROC opendosdisk(TEXT CONST path):IF logflag
THEN dump("open dos disk",path)FI ;enablestop;closework;initclusterhandle;
actpath:=path;diskopen:=TRUE END PROC opendosdisk;PROC closedosdisk:IF 
logflagTHEN dump("close dos disk","")FI ;enablestop;diskopen:=FALSE ;
closework;initclusterhandle;clearfatds;initdirds.END PROC closedosdisk;PROC 
accessdosdisk:enablestop;IF NOT diskopenTHEN errorstop(
"DOS-Arbeit nicht eröffnet")FI ;IF workclosedCOR (
lastaccessmorethan5secondsagoCAND diskchanged)THEN openeudisk;opendosdisk;
readfat;opendir(actpath);lastaccesstime:=clock(1);openworkFI .
lastaccessmorethan5secondsago:abs(clock(1)-lastaccesstime)>5.0.diskchanged:
IF hdversionTHEN FALSE ELSE lastaccesstime:=clock(1);NOT firstfatblockokFI .
END PROC accessdosdisk;REAL VAR nextfetchcluster,fetchrest;PROC 
openfetchdosfile(TEXT CONST filename):IF logflagTHEN dump(
"open fetch dos file",filename)FI ;enablestop;accessdosdisk;fileinfo(filename
,nextfetchcluster,fetchrest).END PROC openfetchdosfile;BOOL PROC 
waslastfetchcluster:IF logflagTHEN dump("was last fetch cluster","")FI ;
islastfatchainentry(nextfetchcluster)OR fetchrest<=0.0.END PROC 
waslastfetchcluster;PROC catnextfetchdoscluster(TEXT VAR buffer):IF logflag
THEN dump("cat next fetch dos cluster","")FI ;enablestop;IF 
waslastfetchclusterTHEN errorstop("fetch nach Dateiende")FI ;IF fetchrest<
real(clustersize)THEN catclustertext(nextfetchcluster,buffer,int(fetchrest));
fetchrest:=0.0ELSE catclustertext(nextfetchcluster,buffer,clustersize);
fetchrestDECR real(clustersize)FI ;lastaccesstime:=clock(1);nextfetchcluster
:=fatentry(nextfetchcluster).END PROC catnextfetchdoscluster;PROC 
readnextfetchdoscluster(DATASPACE VAR readds,INT VAR startpage):IF logflag
THEN dump("read next fetch dos cluster",startpage)FI ;enablestop;IF 
waslastfetchclusterTHEN errorstop("fetch nach Dateiende")FI ;readdiskcluster(
readds,startpage,nextfetchcluster);lastaccesstime:=clock(1);startpageINCR 
sectorspercluster;nextfetchcluster:=fatentry(nextfetchcluster);IF fetchrest<
real(clustersize)THEN fetchrest:=0.0ELSE fetchrestDECR real(clustersize)FI .
END PROC readnextfetchdoscluster;PROC closefetchdosfile:IF logflagTHEN dump(
"close fetch dos file","")FI ;END PROC closefetchdosfile;TEXT VAR savename;
REAL VAR firstsavecluster,lastsavecluster,savesize;PROC opensavedosfile(TEXT 
CONST filename):IF logflagTHEN dump("open save dos file",filename)FI ;
enablestop;accessdosdisk;IF fileexists(filename)OR subdirexists(filename)
THEN errorstop("die Datei """+filename+""" gibt es schon")FI ;savename:=
filename;firstsavecluster:=-1.0;savesize:=0.0.END PROC opensavedosfile;PROC 
writenextsavedoscluster(TEXT CONST buffer):IF logflagTHEN dump(
"write next save dos cluster","")FI ;enablestop;REAL CONST savecluster:=
availablefatentry;writetexttocluster(savecluster,buffer);lastaccesstime:=
clock(1);savesizeINCR real(LENGTH buffer);IF firstsavecluster<2.0THEN 
firstsavecluster:=saveclusterELSE fatentry(lastsavecluster,savecluster)FI ;
fatentry(savecluster,lastfatchainentry);lastsavecluster:=savecluster.END 
PROC writenextsavedoscluster;PROC writenextsavedoscluster(DATASPACE CONST 
saveds,INT VAR startpage):IF logflagTHEN dump("write next save dos cluster",
startpage)FI ;enablestop;REAL CONST savecluster:=availablefatentry;
writediskcluster(saveds,startpage,savecluster);lastaccesstime:=clock(1);
startpageINCR sectorspercluster;savesizeINCR real(clustersize);IF 
firstsavecluster<2.0THEN firstsavecluster:=saveclusterELSE fatentry(
lastsavecluster,savecluster)FI ;fatentry(savecluster,lastfatchainentry);
lastsavecluster:=savecluster.END PROC writenextsavedoscluster;PROC 
closesavedosfile:IF logflagTHEN dump("close save dos file","")FI ;enablestop;
IF firstsavecluster<2.0THEN LEAVE closesavedosfileFI ;fatentry(
lastsavecluster,lastfatchainentry);writefat;insertdirentry(savename,
firstsavecluster,savesize);lastaccesstime:=clock(1).END PROC closesavedosfile
;PROC erasedosfile(TEXT CONST filename):IF logflagTHEN dump("erase dos file",
filename)FI ;enablestop;accessdosdisk;REAL VAR firstcluster,size;fileinfo(
filename,firstcluster,size);deletedirentry(filename);erasefatchain(
firstcluster);writefat;lastaccesstime:=clock(1).END PROC erasedosfile;
THESAURUS PROC alldosfiles:IF logflagTHEN dump("all dosfile","")FI ;
enablestop;accessdosdisk;allfiles.END PROC alldosfiles;THESAURUS PROC 
alldossubdirs:IF logflagTHEN dump("all subdirs","")FI ;enablestop;
accessdosdisk;allsubdirs.END PROC alldossubdirs;BOOL PROC dosfileexists(TEXT 
CONST filename):IF logflagTHEN dump("dos file exists",filename)FI ;enablestop
;accessdosdisk;fileexists(filename).END PROC dosfileexists;PROC doslist(
DATASPACE VAR listds):IF logflagTHEN dump("dos list","")FI ;enablestop;
accessdosdisk;dirlist(listds).END PROC doslist;PROC cleardosdisk:IF logflag
THEN dump("clear dos disk","")FI ;enablestop;IF hdversionTHEN errorstop(
"nicht implementiert")ELSE accessdosdisk;formatdir;formatfat;lastaccesstime:=
clock(1)FI .END PROC cleardosdisk;PROC formatdosdisk(INT CONST formatcode):
IF logflagTHEN dump("format dos disk ("+text(formatcode)+")","")FI ;
enablestop;IF NOT diskopenTHEN errorstop("DOS-Arbeit nicht eröffnet")FI ;IF 
hdversionTHEN errorstop("nicht implementiert")ELSE doformatFI .doformat:IF 
bpbexists(formatcode)THEN closework;formatarchive(formatcode);openeudisk;
writebpb(formatcode);opendosdisk;formatdir;formatfat;openworkELSE errorstop(
"Format unzulässig")FI ;lastaccesstime:=clock(1).END PROC formatdosdisk;END 
PACKET dosgetput;