|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 155904 (0x26100)
Types: TextFile
Names: »packtxt«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »packtxt«
(
mode 0.yes
if 2.yes
algol connect.no bossline.yes xref.yes stop.2
if 2.no
pack=algol connect.no bossline.yes
if warning.yes
mode 0.no
if ok.no
mode 0.no
if 0.yes
(
if 3.no
(
unpack=assign pack
searchpack=assign pack
clearpack=assign pack
repack=assign pack
pointpack=assign pack
purgepack=assign pack
)
)
end)
\f
pack - system : projectno. - 80 10 01
dokumentation : version 1 - 81 09 01/1, brugervejledning
last alteration : eja - 81 12 18
begin
<* her indkopieres globale library procedurer *>
comment algol copy.connecttxt;
comment algol copy.printareax;
comment algol copy.breaktxt;
comment algol copy.monerrtxt;
comment algol copy.getclaimtxt;
comment algol copy.resotxt; algol copy.librarytxt;
message end copy library procedures;
message algolline in source = errorline - this line + 10;
\f
comment
programname (object-code) pack
. (entry) unpack
. ( - ) searchpack
. ( - ) clearpack
. ( - ) repack
. ( - ) pointpack
. ( - ) purgepack
. ( - ) convertpack (not implemented)
programtext (algol8) packtext
version (documentation release) 800701, version 1, testversion
projectleader arne balslev, keld christensen
programmer ejlert andersen (eja)
resources needed std. proces + perm resources for library
. optimal size = 25000 bytes
externals used except algollibrary fpscan
programcall see users manual
tests:
0: filhovede, kataloger ved afslutning af kørsel
1: synlige entries i packfile
2: funktion af forskellige procedurer
3: bloktransporter til/fra kataloger
4: synlige entries i main catalog
5: tidsforbrug
;
\f
comment o v e r s i g t o v e r p r o g r a m s t r u k t u r
.
.begin <* blok 0, pack-programmet *>
.
. <* indkopiering af globale library procedurer *>
.
. connect
. printarea
. break
. monitor_error
. get_claim
. ressource_check
.
. <* globale konstanter *>
. <* dimensioneringsvariable *>
.
. <* globale styrevariable *>
.
. <* field-variable for packfilehead og catalogs *>
.
. <* initialisering af alle de globale variable *>
.
. begin <* blok 1, global programblok *>
.
. <* globale procedurer *>
.
. read_program_call
. begin <* blok 2, indlæsning og test af programkaldet *>
.
. <* hjælpeprocedurer for aflæsning af programkaldet *>
.
. fp_call_error
. print_optionlist
. check_leftside
. check_function
. check_filelist
. getnextparam
. check_param
. check_valuelist
. check_date
.
. <* aflæsning af programkaldet og test af parameterlisten *>
. <* initialisering af funktionsafhængige defaultværdier *>
.
. end <* blok 2, procedure read_program_call *>
.
. quicksort
. discsort
. get_permkit_name
. compute_hashtable_size
.
. initialize_packfile_head(head)
. begin <* blok 2, proceduren åbner til eller opretter en packfile *>
. delay
. init_packfile
. gen_packname
. get_packfile
.
. <* kald af get_packfile *>
.
. gat_packfile(head,pack_tail,
. if program_function = packsym then <* opret *> else <* ikke opret *>)
.
. end <* blok 2, procedure initialize_packfile_head *>
.
.
. main(ud,head)
. begin <* blok 2, procedure main indeholder hovedprogrammet *>
.
. <* centrale programdel *>
.
. empty_out
. recompute_hashkeys
. check_packfile_head
. check_catalogs
. begin
. check_packcat
. check_gapcat
. check_crossref
. end <* check catalogs *>
.
. lookup_auxdoc
. lookup_entry
. search_catalogentry
. lookup_error
. print_date
. print_head_and_tail
. print_modekind
. print_entry
. print_heading
. print_packhead
. print_packcat
. print_gapcat
. print_tables
. testblok
.
. entry_scope
. open_special
. change_scope
. create_entry
. newposition
. next_record
. find_record
. swop_cat
. set_packtail
. movearea
.
. compute_hashkey
. initialize_hashtables
. insert_tableentry
. delete_tableentry
. search_tableentry
. lookup_tableentry
.
. subcompare
. get_nextentryspec
. scan_packentry
. next_packentry
. search_gap
. delete_packentry
. insert_packentry
. reorganize_gapcat
. compute_last_date
. purge
.
. pack
. unpack
. searchpack
. clearpack
. repack
. pointpack
. purgepack
. convertpack
.
. <* buffere for hoved og kataloger *>
.
. packcat(128*1,1)
. gapcat(128*1,1)
.
. <* tabeller til hashing-funktionen *>
.
. boolean array hashtable(1:head.hashtable_size),
. linktable(1:head.packentries)
.
.
. <* hoved program *>
.
. case program_function of
. begin
. -
. -
. end case
.
. end <* blok 2, procedure main *>
.
. <* buffer til packfilens hovede, samt array til programkald *>
.
. zone pack_head(128*1,1)
.
. long array optionlist(1:maxindex)
.
.
. <* starttidspunkt og dato beregnes *>
.
. <* kald af read_program_call *>
.
. read_program_call
.
. <* initialisering af processbaser *>
.
. <* test af processressourcer *>
.
. <* åbning til eller oprettelse af packfile *>
.
. initialize_packfile_head(pack_head)
.
. <* hovedprogrammet afvikles *>
.
. if current_output then
. main(out,pack_head)
. else
. begin
. zone overs(128*1,1)
.
. main(overs,pack_head)
. end
.
. end <* blok 1, global programblok *>
.
.end <* blok 0, pack-program *>
.
;
\f
<* globale konstanter *>
<**********************>
long
_ empty;
integer
_ pack_entry_length,
_ max_pack_entries,
_ max_gap_entries,
_ max_function,
_ max_index,
_ max_params,
_ maxint,
_ nil,
_ free,
_ temp,
_ login,
_ user,
_ project,
_ systemscope,
_ normlist,
_ ownerlist,
_ statlist,
_ packsym,
_ unpacksym,
_ searchpacksym,
_ clearpacksym,
_ repacksym,
_ pointpacksym,
_ purgepacksym,
_ convertpacksym,
_ undefined,
_ maxwaittime,
_ max_timeinterval,
_ maxbsdevices;
\f
<* globale variable for programmet *>
<***********************************>
long array
_ program_name, <* programfunktionsnavnet *>
_ outfile, <* navnet på filen til kørselrapport *>
_ newkit, <* navnet på nye device ved unpack *>
_ ownerid, <* ownerid-navnet for ønskede filer *>
_ packkit, <* navnet på device hvor packfile opret. *>
_ packfile(1:2); <* navnet på pack-filen *>
integer array
_ process_bases(1:8), <* indeholder de aktuelle processbaser *>
_ intern_bases(1:8), <* interne processbaser for packfile *>
_ viewbases(1:2), <* alternative interne processbaser *>
_ pack_tail(1:10); <* indeholder packfilens entrytail *>
boolean array
_ scopelist(0:4); <* markering for bestilte scope's *>
real
_ timebase, <* base for tidsberegninger *>
_ cputime, <* måler cpu-tidsforbruget *>
_ realtime; <* måler real-tidsforbruget *>
integer
_ program_function, <* kode for programfunktionen *>
_ no_of_files, <* antal af filnavne i programkald *>
_ no_of_subtext, <* antal subtext angivelser *>
_ scope, <* scope tæller *>
_ newscope, <* husker nyt scope for unpack-filer *>
_ retention, <* antal dage pakkede filer overlever *>
_ dim_retention, <* do., anvendes ved repackdimensionering*>
_ dim_packentries, <* max. antal indgange i packkatalog *>
_ dim_gapentries, <* max. antal huller i packfilen *>
_ lastdate, <* skæringsdato ved sletning af filer *>
_ deletetype, <* slettedato type ved purgepack *>
_ listtype, <* udskriftstype ved searchpack *>
_ date, <* kørselsdato *>
_ lower_catbase, <* processens nederste katalogbase *>
_ upper_catbase, <* processens øverste katalogbase *>
_ max_bufsegm; <* max. antal segm. i buffer ved flytning*>
boolean
_ convert, <* kørselsrapport udskrives på printer *>
_ current_output, <* kørselsrapport udskrives i zone out *>
_ allowner, <* alle filer med ownerid listes *>
_ allpackfile, <* alle filer listes uden undtagelse *>
_ security, <* security ved repack (user fil) *>
_ remove, <* angiver om pakkede entries slettes *>
_ scopeboo, <* angiver at scopeliste er indlæst *>
_ gapcat_used, <* angiver at hulkataloget anvendes *>
_ hashing_used, <* angiver at hashtabellen initialiseres *>
_ system_packfile, <* packfilen ligger på systemniveau *>
_ viewbase_set; <* alternative internbaser er angivet *>
long array field
_ filelist_adr, <* pointer til listen af filnavne *>
_ subtext_adr; <* pointer til subtext-liste *>
<*+2*>
<* testfaciliteter kan skippes efter ønske med programmet cleaner *>
boolean test;
<*-2*>
\f
<* fieldvariable for catalog/pack entry *>
long array field
_ entryname,
_ documentname,
_ password,
_ auxdocname;
integer array field
_ entry_baseadr,
_ entry_tail;
integer field
_ key,
_ lowerbase,
_ upperbase,
_ areasize,
_ storeaddress,
_ packdate,
_ last_accessdate,
_ no_of_read,
_ no_of_point,
_ entryindex,
_ hashkey,
<* field variable for packfile_head *>
_ entrylength,
_ packentries,
_ gapentries,
_ gapcat_adr,
_ first_areasegm,
_ no_of_entries,
_ no_of_segm,
_ no_of_gaps,
_ no_of_gapsegm,
_ retentiondays,
_ last_update,
_ packfile_size,
_ creation_date,
_ update_mark,
_ hashtable_size,
_ last_function,
_ extend_mark,
<* fieldvariable for gapcat_entry *>
_ first_emptysegm,
_ no_of_emptysegm;
\f
<* initialisering af globale konstanter *>
<****************************************>
pack_entry_length := 64; <* længde af pack_entry i bytes *>
max_pack_entries := 50; <* max antal indgange i packcatalog *>
max_gap_entries := 128; <* max antal huller i packfilen *>
max_function := 7; <* antal program-funktioner *>
max_index := 500; <* max længde for programkald *>
max_params := 16+1; <* antallet af kendte fpparametre *>
maxbsdevices := 10; <* max ant. disckit i ressource besk.*>
maxwaittime := 50; <* ventid for packfile i cpusec. *>
max_timeinterval := 5; <* ventetid mel. reserve af packfile *>
maxint :=8388607; <* max. positiv heltal *>
temp := 0; <* kode for scope.temp *>
login := 1; <* kode for scope.login *>
user := 2; <* kode for scope.user *>
project := 3; <* kode for scope.project *>
systemscope := 4; <* kode for scope.system *>
undefined := 5; <* kode for udefineret scope *>
normlist := 1; <* kode for normal listning af entry *>
ownerlist := 2; <* kode for ydeligere list af owner *>
statlist := 3; <* kode for listning af statistikker *>
packsym := 1;
unpacksym := 2;
searchpacksym := 3;
clearpacksym := 4;
repacksym := 5;
pointpacksym := 6;
purgepacksym := 7;
convertpacksym := 8;
empty :=long <::>; <* tomt tekstelement *>
\f
<* initialisering af fieldvariable for catalog/pack entry *>
entry_baseadr := 0;
key := 2;
lowerbase := 4;
upperbase := 6;
entryname := 6;
areasize := 16;
documentname := 16;
entrytail := 24;
storeaddress := 36;
password := 36;
packdate := 46;
last_accessdate := 48;
no_of_read := 50;
no_of_point := 52;
auxdocname := 52;
entryindex := 62;
hashkey := 64;
<* initialisering af fieldvariable for packfile_head *>
entrylength := 2;
packentries := 4;
gapentries := 8;
gapcat_adr := 12;
first_areasegm := 14;
no_of_entries := 16;
no_of_segm := 18;
no_of_gaps := 20;
no_of_gapsegm := 22;
retentiondays := 24;
last_update := 26;
packfile_size := 28;
creation_date := 30;
update_mark := 32;
hashtable_size := 34;
last_function := 36;
extend_mark := 38;
<* initialisering af fieldvariable for gapcat *>
first_emptysegm := 2;
no_of_emptysegm := 4;
\f
<* styrevariable initialiseres *>
no_of_subtext := 0;
newscope := undefined;
retention := maxint;
dim_retention :=
dimpackentries:=
dim_gapentries:=
lastdate := 0;
listtype :=
deletetype := 1;
current_output:=
security := true;
convert :=
scopeboo :=
allowner :=
allpackfile :=
systempackfile:=
remove :=
viewbase_set := false;
<*+2*>
test := false;
<*-2*>
outfile(1) :=
outfile(2) :=
packfile(1) :=
packfile(2) :=
packkit(1) :=
packkit(2) :=
newkit(1) :=
newkit(2) :=
ownerid(1) :=
ownerid(2) := empty;
viewbases(2) := maxint;
for scope:=temp step 1 until systemscope do
scopelist(scope):=false;
\f
<* globale programblok *>
<* ------------------- *>
begin
procedure read_program_call;
<**************************>
<* indlæser programkaldet og den tilhørende parameterliste *>
<* herefter testes og analyseres indholdet for fejlelementer *>
begin
procedure fp_call_error(no,index);
<********************************>
value no,index ;
integer no,index ;
<*
udskriver programkaldet og giver en fejlmeddelelse
ved fejl i programkaldets parametre
*>
begin
integer
_ place_of_error;
place_of_error:=printoptionlist(1,index-1,0);
write(out,<: -->> :>);
printoptionlist(index,max_index,place_of_error);
write(out,"nl",2,<:*** error in parameter list, :>,
case no of (
<* 1 *> <:parameter list too long:>,
<* 2 *> <:seperator between parameter and value not ".":>,
<* 3 *> <:parameter name not text:>,
<* 4 *> <:parameter name unknown:>,
<* 5 *> <:parameter not allowed with this program function:>,
<* 6 *> <:valuelist of mixed type not allowed:>,
<* 7 *> <:number of elements in valuelist exceeds maximum:>,
<* 8 *> <:valuelist of type integer, should be of type text:>,
<* 9 *> <:valuelist of type text, should be of type integer:>,
<* 10 *> <:parameter value element unknown or of illegal value:>,
<* 11 *> <:parameter name read twice:>,
<* 12 *> <:valuelist not complete:>,
<* 13 *> <:program function unknown:>,
<::>));
break(<::>,0,true);
end fp_call_error;
\f
integer procedure printoptionlist(firstel,lastel,lastpos);
<********************************************************>
value firstel,lastel,lastpos ;
integer firstel,lastel,lastpos ;
<*
udskriver programkaldet på current output
*>
begin
long array
_ textel(1:2);
integer
_ i,
_ spaces;
textel(2):=long <::>;
if firstel = 1 then
begin
spaces:=1;
outchar(out,'nl');
outchar(out,'*');
end
else spaces:=lastpos;
for i:=firstel step 1 until lastel do
begin
case kind(i) of
begin
<* seperator *>
begin
outchar(out,optionlist(i) extract 12);
spaces:=spaces+1;
end;
<* integer number *>
spaces:=spaces + write(out,<<d>,optionlist(i));
<* textparameter *>
begin
textel(1):=optionlist(i);
spaces:=spaces+write(out,textel);
end;
end case kind(i);
if spaces > 50 and kind(i) = seperator then
begin
outchar(out,'nl');
spaces:=0;
end;
end elements;
printoptionlist:=spaces;
end printoptionlist;
\f
boolean procedure check_leftside(name);
<*************************************>
long array name ;
<*
undersøger om venstreside er angivet i programkaldet
returværdi:
true : udfil angivet - name indeholder navnet hvis ikke "convert"
false: udfil ikke angivet
*>
begin
if optionlist(3) = '=' then
begin
check_leftside:=true ;
current_output:=false;
if optionlist(1) = long <:c:>
or optionlist(1) = long <:conve:> add 'r'
then convert:=true
else
begin
name(1):=optionlist(1);
name(2):=optionlist(2);
end;
end
else
begin
check_leftside:= false;
name(1) := long <:c:>;
end;
end check_leftside;
\f
integer procedure check_function(index);
<**************************************>
integer index ;
<*
returnerer programfunktionen
0 : ukendt
1 : pack
2 : unpack
3 : searchpack
4 : clearpack
5 : repack
6 : pointpack
7 : purgepack
*>
begin
long
_ pname;
pname:=optionlist(index);
index:=index + 2;
check_function:=
if pname = long <:pack:> then 1 else
if pname = long <:unpac:> add 'k' then 2 else
if pname = long <:searc:> add 'h' then 3 else
if pname = long <:clear:> add 'p' then 4 else
if pname = long <:repac:> add 'k' then 5 else
if pname = long <:point:> add 'p' then 6 else
if pname = long <:purge:> add 'p' then 7 else
if pname = long <:conve:> add 'r' then 8 else
_ 0 ;
end check_function;
\f
integer procedure check_filelist(index,adr);
<******************************************>
integer index,adr ;
<*
returnerer antallet af filnavne i fillisten
og adressen på første filnavn i parameterlisten
*>
begin
integer
_ namecount;
boolean
_ more;
namecount:=0; adr:=index*4; more:=true;
while optionlist(index) = 'sp' and kind(index) = seperator and more do
if index + 3 <= max_index + 1 then
begin
if (optionlist(index+3) = 'sp' or kind(index+3) = 0) and kind(index+1) = text then
begin
index:=index+3;
namecount:=namecount+1;
end
else
if optionlist(index+3) = '.' and kind(index+1) = text then
begin
if index + 9 <= maxindex + 1 then
begin
if optionlist(index+6) = '.' and kind(index+4) = text and kind(index+7) = text then
begin
if optionlist(index+4) = long <:scope:>
and optionlist(index+5) = long <::>
and (optionlist(index+7) = long <:temp:>
or optionlist(index+7) = long <:login:>
or optionlist(index+7) = long <:user:>
or optionlist(index+7) = long <:proje:> add 'c'
)
then
begin
index:= index + 9;
namecount:= namecount + 1;
end
else more:=false;
end
else more:=false;
end
else more:=false;
end
else more:=false;
end
else more:=false;
check_filelist:=namecount;
end check_filelist;
\f
integer procedure getnextparam(index,no_of_values,adrix,listtype);
<****************************************************************>
integer index,no_of_values,adrix,listtype ;
<*
returnerer parameternummeret og antallet af værdielementer
for næste parameter i programkaldet
returnvalue:
- 5 : værdiliste af blandet type
- 4 : parameter ikke tilladt
- 3 : skilletegn ikke '.'
- 2 : integer
- 1 : parameter ukendt
0 : slut på parameterlisten
ellers nummeret på parameteren i navne kataloget
*>
begin
integer
_ return,
_ ccount;
boolean
_ firstel,
_ found,
_ more;
no_of_values:=listtype:=0; found:=false;
if index+1 > max_index then return:= 0 else
if kind(index+1) = number then return:=-2 else
if optionlist(index+3) <> '.' then return:=-3 else
begin
for ccount:=1, ccount+1 while ccount <= max_params and -,found do
if namecat(ccount) = optionlist(index+1) then
begin
found:= true;
return:= if check_param(if program_function = convertpacksym then
_ repacksym else program_function,ccount)
then ccount else (-4);
end;
if -,found then return:=-1;
index:=index+3;
adrix:=index+1;
more :=true; firstel:=true;
while more and index <= max_index do
if optionlist(index) = '.' then
begin
if firstel then
begin
firstel :=false;
listtype:=kind(index+1);
end
else
if listtype <> kind(index+1) then
begin
listtype:= 0;
if found then
return :=-5;
end;
no_of_values:=no_of_values + 1;
index :=index + (if kind(index+1) = text then 3 else 2);
end
else more:=false;
end;
getnextparam:=return;
end getnextparam;
\f
boolean procedure check_param(function,paramno);
<**********************************************>
value function,paramno ;
integer function,paramno ;
<*
undersøger om parameteren er tilladt ved programfunktionen
*>
check_param:=case (paramno-1)*max_function + function of (
<* function 1 2 3 4 5 6 7 *>
<* - - - - - - - pack unpack search clear repack point purge *>
<* parameter-no *>
<* 1,subtext *> true, true, true, false, false, true, false,
<* 2,scope *> true, true, true, false, false, true, false,
<* 3,packfile *> true, true, true, true, true, true, true,
<* 4,owner *> true, true, true, true, false, true, false,
<* 5,newscope *> true, true, false, false, false, true, false,
<* 6,retention *> true, false, false, false, true, false, false,
<* 7,all *> false, false, true, false, false, false, false,
<* 8,lastdate *> false, false, false, false, false, false, true,
<* 9,maxentries *> true, false, false, false, true, false, false,
<*10,security *> false, false, false, false, true, false, false,
<*11,maxgaps *> true, false, false, false, true, false, false,
<*12,changekit *> true, true, false, false, false, true, false,
<*13,list *> false, false, true, false, false, false, false,
<*14,deletetype *> false, false, false, false, false, false, true,
<*15,remove *> true, false, false, false, false, false, false,
<*16,base *> false, true, false, true, false, true, false,
<*xx,test *> true, true, true, true, true, true, true);
\f
integer procedure check_valuelist(paramno,type,no_of_values);
<***********************************************************>
value paramno,type,no_of_values ;
integer paramno,type,no_of_values ;
<*
undersøger typen og elementantallet for
værdilisten for en given parameter
*>
begin
integer array
_ param(1:2);
integer
_ no;
for no:=1,2 do
param(no):=case (paramno-1)*2 + no of (
<* parameter_no. type max. antal *>
<* 1,subtext *> text, maxint,
<* 2,scope *> text, 4,
<* 3,packfile *> text, 2,
<* 4,owner *> text, 1,
<* 5,newscope *> text, 1,
<* 6,retention *> number, 1,
<* 7,all *> text, 1,
<* 8,lastdate *> number, 1,
<* 9,maxentries *> number, 1,
<*10,security *> text, 1,
<*11,maxgaps *> number, 1,
<*12,changekit *> text, 1,
<*13,list *> text, 1,
<*14,deletetype *> text, 1,
<*15,remove *> text, 1,
<*16,base *> number, 2,
<* x,test *> number, 12 );
check_valuelist:=
if type <> param(1) then type else
if no_of_values > param(2) then 1 else 0;
end check_valuelist;
\f
boolean procedure check_date(first,last,date);
<********************************************>
value first,last,date ;
integer first,last,date ;
<* tester lovligheden af en datoangivelse *>
begin
boolean
_ ok;
integer
_ yy,
_ mm,
_ dd;
yy:= date // 10000;
mm:= date // 100 mod 100;
dd:= date mod 100;
ok:=
date >= first and
date <= last and
mm >= 1 and
mm <= 12 and
dd >= 1 ;
if ok then
ok:= dd <= (case mm of (31, if yy mod 4 = 0 then 29 else 28,
_ 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
check_date:= ok;
end check_date;
\f
long array
_ namecat(1:maxparams);
integer array
_ kind(1:max_index);
boolean array
_ param_read(1:max_params);
integer
_ parameter_type, <* kode for aktuel parameter i listen *>
_ parameter_values, <* antal læste værdier for en given parameter *>
_ valuelist_type, <* typen for en parameters værdiliste *>
_ valuelist_adr, <* index til værdiliste for given parameter *>
_ fp_index, <* løbende index til parameterlisten *>
_ old_index, <* husker tidligere index i parameterlisten *>
_ count, <* hjælpe variabel *>
_ seperator, <* kind for skilletegn i parameterliste *>
_ number, <* kind for heltal i parameterliste *>
_ text; <* kind for text i programkald *>
seperator := 1;
number := 2;
text := 3;
\f
<* initialisering af kendte parameternavne *>
for count:=1 step 1 until max_params do
begin
param_read(count):= false;
namecat(count):=long (case count of(
<* 1 *> <:subte:> add 'x',
<* 2 *> <:scope:> ,
<* 3 *> <:packf:> add 'i',
<* 4 *> <:owner:> ,
<* 5 *> <:newsc:> add 'o',
<* 6 *> <:reten:> add 't',
<* 7 *> <:all:> ,
<* 8 *> <:lastd:> add 'a',
<* 9 *> <:maxen:> add 't',
<* 10 *> <:secur:> add 'i',
<* 11 *> <:maxga:> add 'p',
<* 12 *> <:chang:> add 'e',
<* 13 *> <:list:> ,
<* 14 *> <:delet:> add 'e',
<* 15 *> <:remov:> add 'e',
<* 16 *> <:base:> ,
<* xx *> <:test:> ));
end;
<* parameterlisten indlæses i <optionlist> typerne i <kind> *>
max_index:=fp_scan(optionlist,kind);
if max_index < 0 then fp_call_error(1,abs max_index);
<* venstreside, programnavn og filnavneliste undersøges *>
fp_index:=if check_leftside(outfile) then 4 else 1;
program_name(1):=optionlist(fp_index);
program_name(2):=optionlist(fp_index+1);
program_function:=check_function(fp_index);
if program_function = 0 then fp_call_error(13,fp_index - 2);
no_of_files:=check_filelist(fp_index,filelist_adr);
\f
<* nu læses resten af parameterlisten *>
old_index:=fp_index;
for parameter_type:=getnextparam(fp_index,parameter_values,valuelist_adr,valuelist_type)
while parameter_type <> 0 do
begin
<*+1*>
if test shift(-2) then <* aktiveres først efter læsning af testparameter *>
write(out,<:<'nl'>paramtype, index, values, valueadr :>,<<ddddd>,
parameter_type,fp_index,parameter_values,valuelist_adr);
<*-1*>
if parameter_type > 0 then
begin
if -,param_read(parameter_type)
then param_read(parameter_type):= true
else fp_call_error(11,old_index);
count:=check_valuelist(parameter_type,valuelist_type,parameter_values);
if count > 0 then fp_call_error(6+count,valuelist_adr);
end;
case parameter_type + 6 of
begin
<* -5, valuelist of mixed type *>
fp_call_error(6,valuelist_adr);
<* -4, parameter not allowed *>
fp_call_error(5,old_index);
<* -3, seperator not '.' *>
fp_call_error(2,fp_index);
<* -2, integer - not text *>
fp_call_error(3,fp_index);
<* -1, parameter unknown *>
fp_call_error(4,old_index);
<* 0, not used ! *> ;
<* subtext *>
begin
no_of_subtext:=parametervalues;
subtext_adr :=(valuelist_adr-1)*4;
end;
<* scope *>
begin
scopeboo:=true;
for count:=valuelist_adr step 3 until valuelist_adr + (parameter_values - 1) * 3 do
begin
scope:=
if optionlist(count) = long <:temp:> then temp else
if optionlist(count) = long <:login:> then login else
if optionlist(count) = long <:user:> then user else
if optionlist(count) = long <:proje:> add 'c' then project else -1;
if scope > -1
then scopelist(scope):=true
else fp_call_error(10,count);
end;
end;
<* packfile *>
begin
packfile(1):=optionlist(valuelist_adr );
packfile(2):=optionlist(valuelist_adr+1);
if parametervalues > 1 then
begin
packkit(1):=optionlist(valuelist_adr+3);
packkit(2):=optionlist(valuelist_adr+4);
end;
end;
<* owner *>
begin
ownerid(1):=optionlist(valuelist_adr );
ownerid(2):=optionlist(valuelist_adr+1);
end;
<* newscope *>
begin
for count:=valuelist_adr step 3 until valuelist_adr+(parameter_values - 1) * 3 do
begin
scope:=
if optionlist(count) = long <:temp:> then temp else
if optionlist(count) = long <:login:> then login else
if optionlist(count) = long <:user:> then user else
if optionlist(count) = long <:proje:> add 'c' then project else -1;
if scope <> -1 and newscope = undefined then
newscope:= scope else fp_call_error(10,count);
end;
end;
<* retention *>
retention:=dim_retention:=optionlist(valuelist_adr);
<* all *>
if optionlist(valuelist_adr) = long <:owner:> then allowner:=true else
if optionlist(valuelist_adr) = long <:packf:> add 'i' then allpackfile:=true else
fp_call_error(10,valuelist_adr);
<* lastdate *>
begin
lastdate:=optionlist(valuelist_adr);
if -,check_date(700101,date,lastdate) then fp_call_error(10,valuelist_adr);
end;
<* maxentries *>
if optionlist(valuelist_adr) >= 15 and optionlist(valuelist_adr) < 4095 then
dim_packentries :=
max_pack_entries:= optionlist(valuelist_adr)
else fp_call_error(10,valuelist_adr);
<* security *>
if optionlist(valuelist_adr) = long <:no:> then security:=false else
if optionlist(valuelist_adr) <> long <:yes:> then fp_call_error(10,valuelist_adr);
<* maxgaps *>
if optionlist(valuelist_adr) >= 15 and optionlist(valuelist_adr) < 4095 then
dim_gapentries :=
max_gap_entries:= optionlist(valuelist_adr)
else fp_call_error(10,valuelist_adr);
<* changekit *>
if newkit(1) = empty then
begin
newkit(1):= optionlist(valuelist_adr );
newkit(2):= optionlist(valuelist_adr+1);
end
else fp_call_error(10,valuelist_adr);
<* list *>
if optionlist(valuelist_adr) = long <:norma:> add 'l' then listtype:= 1 else
if optionlist(valuelist_adr) = long <:stati:> add 's' then listtype:= 2 else
if optionlist(valuelist_adr) = long <:entry:> then listtype:= 3 else
fp_call_error(10,valuelist_adr);
<* deletetype *>
if optionlist(valuelist_adr) = long <:entry:> add 'd' then deletetype:= 1 else
if optionlist(valuelist_adr) = long <:packd:> add 'a' then deletetype:= 2 else
if optionlist(valuelist_adr) = long <:acces:> add 's' then deletetype:= 3 else
fp_call_error(10,valuelist_adr);
<* remove *>
if optionlist(valuelist_adr) = long <:yes:> then remove:= true else
if optionlist(valuelist_adr) = long <:no:> then remove:= false else
fp_call_error(10,valuelist_adr);
<* base *>
begin
viewbase_set:= true;
viewbases(1):= optionlist(valuelist_adr);
if parametervalues > 1 then
begin
if optionlist(valuelist_adr + 2) >= viewbases(1) then
viewbases(2):= optionlist(valuelist_adr + 2) else
fp_call_error(10,valuelist_adr + 2);
end
else fp_call_error(12,valuelist_adr);
end;
<* her indsættes nye parametre *>
<* test *>
begin
<*+2*>
boolean array testbits(0:11);
for count:= 0 step 1 until 11 do testbits(count):= false;
for count:=valuelist_adr step 2 until valuelist_adr+(parameter_values - 1) * 2 do
if optionlist(count) <= 11 then testbits(optionlist(count)):=true
else fp_call_error(10,count);
<* pakning af testbits *>
for count:=0 step 1 until 11 do
test:=test shift 1 add (testbits(11-count) extract 1);
<*-2*>
<*+1*>
if false then
<*-1*>
<*+2*>
begin
if test shift(-1) or test shift(-2) or test shift(-4) then
write(out,<:<10>*** only test.0.3.5 can be activated !:>);
end;
if false then
<*-2*>
write(out,<:<10>*** testfacilities are missing !:>);
end;
end case parameter_type;
old_index:=fp_index;
end while parameter_type <> 0;
<* initialisering af nogle styrevariable *>
gapcat_used:= case program_function of (
<* pack *> true,
<* unpack *> false,
<* searchpack *> false,
<* clearpack *> true,
<* repack *> true,
<* pointpack *> false,
<* purgepack *> true,
<* convertpack *> false);
hashing_used:=
<*+2*>
program_function = convertpacksym or
<*-2*>
program_function = packsym or
program_function = unpacksym and no_of_files > 0 or
program_function = pointpacksym and no_of_files > 0 or
program_function = clearpacksym;
<* initialisering af specielle defaultværdier *>
if newscope = undefined then
newscope:=
if program_function = unpacksym then login else
if program_function = pointpacksym then temp else
newscope;
if -,scopeboo
and no_of_files = 0
and no_of_subtext = 0
and (program_function = packsym
or program_function = unpacksym
or program_function = pointpacksym
)
then scopeboo:= scopelist(login):= true;
<*+1*>
if test shift(-2) then
begin
printoptionlist(1,max_index,0);
write(out,"nl",2,<<dddddddd>,
<:<10>antal filer i fillisten :>,no_of_files,
<:<10>antal subtext angivelser :>,no_of_subtext,
"nl",1);
if scopeboo then
for scope:=temp step 1 until project do
if scopelist(scope) then
write(out,<:<10>scope = :>,
_ case scope + 1 of (<:temp:>,<:login:>,<:user:>,<:project:>));
write(out,"nl",1);
end test;
<*-1*>
end procedure read_program_call;
\f
procedure quicksort(a,n,s,ix);
<****************************>
value n,s,ix ;
integer array a ;
integer n,s,ix ;
<*
sorterer array 'a' v.h.a. quicksort algoritmen.
n = antal rækker, s = antal søjler,
ix = søjlenr, hvorefter der skal sorteres.
kilde: niklaus wirth, algorithms + data structures = programs,
_ p. 80. new jersey 1976.
*>
begin
real array
_ stack(1:entier(ln(n)/ln(2)) + 1);
integer
_ x,
_ w; <* x, w of same type as 'a' *>
integer
_ i,
_ j,
_ k,
_ l,
_ r;
real array field
_ top;
integer field
_ left,
_ right;
left := 2;
right:= 4;
top:= 0;
stack.top.left := 1;
stack.top.right:= n;
repeat <* take top request from stack *>
l:= stack.top.left;
r:= stack.top.right;
top:= top - 4;
repeat <* split a(l) ... a(r) *>
i:= l;
j:= r;
x:= a((l+r)//2, ix);
repeat
while a(i,ix) < x do i:= i + 1;
while x < a(j,ix) do j:= j - 1;
if i <= j then
begin <* exchange *>
for k:=1 step 1 until s do
begin
w := a(i,k);
a(i,k):= a(j,k);
a(j,k):= w;
end;
i := i + 1;
j := j - 1;
end;
until i > j;
if j - l < r - i then
begin
if i < r then
begin <* stack request for sorting the right partition *>
top:= top + 4;
stack.top.left := i;
stack.top.right:= r;
end;
r:= j; <* continue sorting left partition *>
end
else
begin
if l < j then
begin <* stack request for sorting the left partition *>
top:= top + 4;
stack.top.left := l;
stack.top.right:= j;
end;
l:= i; <* continue sorting the right partition *>
end;
until l >= r;
until top < 0;
end quicksort;
\f
procedure discsort(filnavn,læ,antalindiv,segmprblok,startsegm,
_ k1,k2,k3,k4,k5);
<************************************************************>
value segmprblok ;
string filnavn ;
integer læ,antalindiv,segmprblok,startsegm,
_ k1,k2,k3,k4,k5;
begin
comment
sortering ved søren lauesens 'sldisksort'.
proceduren modificeret mht:
1) sorteringen starter først i <startsegm>.
2) der sorteres efter 5 nøgler, 4 longs og 1 integer
bjj 790222
eja 810927, udvidet til 5 nøgler
;
integer fysisksubbloklængde, fysiskbloklængde, b;
integer array ia(1:20);
array ra(1:2);
fysisksubbloklængde := 512 * segmprblok;
b:= (system(2,b,ra)-8*512)//(2*fysisksubbloklængde);
fysiskbloklængde := b * fysisksubbloklængde;
segmprblok := b * segmprblok;
begin
integer diff, fa, indivlæ2, logiskbloklængde, start,
logisksubbloklængde, nedbasis, nedplads, nedslut, opbasis,
opplads, opslut, slut2, start2, subblokstart, transporter;
integer field indivlæ;
real r;
real field i;
array field m, ned, op;
integer array nuvblok(0:1);
zone z(fysiskbloklængde//2,1,blproc);
long mid1, mid2, mid3, mid4, prim1, prim2, prim3, prim4;
integer mid5;
long field nøgle1, nøgle2, nøgle3, nøgle4;
integer field nøgle5;
procedure blproc(z,s,b);
zone z;
integer s, b;
if s extract 19 < 1 shift 18 or ia(4)<>5 shift 12 then
stderror(z,s,b);
procedure io(plads,operation);
integer plads, operation;
begin
b:=nuvblok(plads)*segmprblok;
if b>=0 then
begin
ia(4):= operation shift 12;
ia(7):= b+start;
ia(5):= b:= fa + plads*fysiskbloklængde;
ia(6):= b + fysiskbloklængde - 2;
setshare(z,ia,1);
monitor(16,z,1,ia);
check(z);
end
end io;
procedure quicksort(start,slut,enblok);
value start, slut, enblok;
integer start, slut;
boolean enblok;
begin
for m:=start+(slut-start)//indivlæ2*indivlæ while start<slut-indivlæ2 do
begin
op:= start-opbasis;
ned:= slut-nedbasis;
if enblok then m:= m - opbasis else
begin
transporter:=0;
transport(m,0,opplads,nedplads);
nedslut:=ned;
opslut:=op;
end;
mid1:= z.m.nøgle1;
mid2:= z.m.nøgle2;
mid3:= z.m.nøgle3;
mid4:= z.m.nøgle4;
mid5:= z.m.nøgle5;
søgned:
ned:= ned-indivlæ;
if ned < nedslut then
begin
transport(ned,nedbasis,nedplads,opplads);
nedslut:= subblokstart;
end;
prim1:= z.ned.nøgle1 - mid1;
prim2:= z.ned.nøgle2 - mid2;
prim3:= z.ned.nøgle3 - mid3;
prim4:= z.ned.nøgle4 - mid4;
if
(if prim1 = 0 then
(if prim2 = 0 then
(if prim3 = 0 then
(if prim4 = 0 then z.ned.nøgle5 > mid5 else prim4 > 0)
_ else prim3 > 0)
_ else prim2 > 0)
_ else prim1 > 0)
then goto søgned;
søgop:
op:= op+indivlæ;
if op >= opslut then
begin
transport(op,opbasis,opplads,nedplads);
opslut:= subblokstart + logisksubbloklængde;
if transporter=3 then enblok:= nedslut=subblokstart;
end;
prim1:= z.op.nøgle1 - mid1;
prim2:= z.op.nøgle2 - mid2;
prim3:= z.op.nøgle3 - mid3;
prim4:= z.op.nøgle4 - mid4;
if
(if prim1 = 0 then
(if prim2 = 0 then
(if prim3 = 0 then
(if prim4 = 0 then z.op.nøgle5 < mid5 else prim4 < 0)
_ else prim3 < 0)
_ else prim2 < 0)
_ else prim1 < 0)
then goto søgop;
if op+opbasis < ned+nedbasis then
begin
for i:=4 step 4 until indivlæ do
begin
r:=z.op.i;
z.op.i:=z.ned.i;
z.ned.i:=r
end;
if indivlæ extract 2 > 0 then
begin
i:= z.op.indivlæ;
z.op.indivlæ:=z.ned.indivlæ;
z.ned.indivlæ:=i;
end;
goto søgned;
end;
slut2:= op+opbasis;
start2:= start;
start:= ned+nedbasis;
if slut-start < slut2-start2 then
begin
i:=slut;
slut:=slut2;
slut2:=i;
i:=start;
start:=start2;
start2:=i;
end;
if start2<slut2-indivlæ2 then quicksort(start2,slut2,enblok);
end for m;
end quicksort;
procedure transport(fysisk,basis,plads,andenplads);
integer fysisk, basis, plads, andenplads;
begin
integer logisk, blok, blokrel, subbloknr, blokbasis;
logisk:= fysisk+basis;
blok:= logisk//logiskbloklængde;
blokrel:= logisk mod logiskbloklængde;
if blok = nuvblok(0) then plads := 0 else
if blok = nuvblok(1) then plads := 1 else
begin
plads := 1-andenplads;
io(plads,5);
nuvblok(plads):= blok;
io(plads,3);
end;
subbloknr := blokrel//logisksubbloklængde;
blokbasis := plads * fysiskbloklængde;
fysisk := blokrel + subbloknr * diff + blokbasis;
subblokstart := subbloknr * fysisksubbloklængde + blokbasis;
basis := logisk - fysisk;
transporter := transporter + 1;
end transport;
open(z,4,filnavn,1 shift 18);
close(z,false);
getzone(z,ia);
fa:=ia(19)+1;
getshare(z,ia,1);
start:=startsegm;
nøgle1:= k1;
nøgle2:= k2;
nøgle3:= k3;
nøgle4:= k4;
nøgle5:= k5;
indivlæ:=læ;
indivlæ2:=2*indivlæ;
if nøgle1<2 or indivlæ<nøgle1 then system(9,nøgle1,<:<10>index :>);
diff:= fysisksubbloklængde mod indivlæ;
logisksubbloklængde := fysisksubbloklængde - diff;
logiskbloklængde := b * logisksubbloklængde;
nuvblok(0) := nuvblok(1) := -1;
opbasis:= nedbasis:= nedplads:= 0;
quicksort(-indivlæ,indivlæ*antalindiv, false);
io(0,5);
io(1,5);
end zone blok;
end disksort;
\f
boolean procedure get_permkit_name(packkit);
<******************************************>
long array packkit ;
<* finder et bsdevice, hvor der er permanente ressourcer *>
begin
integer array
_ claims(1:6 + 11*maxbsdevices); <* ressourcebeskr. for bl.a. bs-devices *>
integer
_ count,
_ segments,
_ slicelength;
integer array field
_ devbase;
long array field
_ dev;
slicelength:=0;
segments :=0;
dev :=0;
devbase :=12;
<* processens ressourcebeskrivelser hentes *>
if -,get_claim(claims) then
break(<:*** all resource descriptions cannot be stored, max. bsdevices:>,maxbsdevices,true);
for count:=1 step 1 until claims(6) do
begin
if claims.devbase(10) > 0 <* entries *>
and claims.devbase(11) > 0 <* segments *>
and (claims.devbase(11) > segments
or claims.devbase(11) = segments
and claims.devbase(5) > slicelength) then
begin
dev :=devbase;
segments :=claims.devbase(11);
slicelength:=claims.devbase(5);
end;
devbase:=devbase + 22;
end;
if dev > 0 then <* permanente ressourcer tilstæde *>
begin
get_permkit_name:= true;
for count:=1,2 do
packkit(count):=claims.dev(count);
end
else
begin
get_permkit_name:= false;
packkit(1):= extend 1 shift 24 ; <* prefering a disckit with temp resources *>
write(out,"nl",1,<:*** no permanent resources available on any bsdevice<10>:>);
end;
end get_permkit_name;
\f
integer procedure compute_hashtable_size(max_entries);
<****************************************************>
value max_entries ;
integer max_entries ;
<*
finder det mindste primtal, som er større end max_entries.
dette tal er således størrelsen på den anvendte hashtabel.
*>
begin
real
_ help_real;
integer
_ candidate,
_ div,
_ square_root;
boolean
_ found;
candidate:= if max_entries mod 2 = 0 then
_ max_entries + 1 else max_entries;
found:= false;
repeat
help_real := candidate;
square_root := sqrt(help_real);
div:= 1;
repeat div:= div + 2;
until candidate mod div = 0 or div > square_root;
if div > square_root
then found:= true
else candidate:= candidate + 2;
until found;
compute_hashtable_size:= candidate;
<*+1*>
if test shift(-2) then
write(out,<:<10>compute_hashtable_size =:>,candidate);
<*-1*>
end compute_hashtable_size;
\f
procedure initialize_packfile_head(head);
<***************************************>
zone head ;
<*
indlæser hovedet fra en packfil. hvis pack
oprettes en packfil hvis denne ikke findes
*>
begin
procedure delay(seconds);
<***********************>
integer seconds ;
<*
stopper programmets udførelse
i <seconds> antal sekunder
*>
begin
zone
_ clock(1,1,stderror);
integer array
_ sh_descr(1:12);
open(clock,2,<:clock:>,0);
getshare6(clock,sh_descr,1);
sh_descr(4):= 0;
sh_descr(5):= seconds;
setshare6(clock,sh_descr,1);
monitor(16)send_message:(clock,1,sh_descr);
monitor(18)wait_answer:(clock,1,sh_descr);
close(clock,true);
end delay;
\f
procedure init_packfile(z,tail);
<******************************>
zone z ;
integer array tail ;
<*
proceduren initialiserer
hovedet, og katalogerne
i den nyoprettede packfile
*>
begin
integer
_ catsegm,
_ gap_catsegm,
_ i;
integer array field
_ iaf;
gap_catsegm:=(max_gap_entries-1)//(512//4)+1;
cat_segm :=(max_pack_entries-1)//(512//pack_entry_length)+1;
<* nulstilling af packfile *>
setposition(z,0,0);
outrec6(z,512);
for i:=1 step 1 until 128 do z(i):= real <::>;
for i:=1 step 1 until cat_segm + gap_catsegm do outrec6(z,512);
setposition(z,0,0);
iaf:=0;
swoprec6(z,512);
for i:=1 step 1 until 17 do
z.iaf(i):=case i of (
<* 1 *> pack_entry_length,
<* 2 *> max_pack_entries,
<* 3 *> 0,
<* 4 *> max_gap_entries,
<* 5 *> 0,
<* 6 *> 1 + cat_segm,
<* 7 *> 1 + cat_segm + gap_cat_segm,
<* 8 *> 0,
<* 9 *> 0,
<* 10 *> 0,
<* 11 *> 0,
<* 12 *> retention,
<* 13 *> date,
<* 14 *> 1 + cat_segm + gap_cat_segm,
<* 15 *> date,
<* 16 *> 0,
<* 17 *> compute_hashtable_size(max_pack_entries));
monitor(44)cut_entry_size:(z,0,tail);
setposition(z,0,0);
end init_packfile;
\f
procedure gen_packname(la);
<*************************>
long array la ;
<*
genererer navn for packfile
ud fra procesnavnet på
formen: xxxpack, dog max.
11 karakter for filnavn.
*>
begin
long array
_ processname(1:2);
integer
_ i,
_ ix,
_ char,
_ pos;
boolean
_ more;
<* hent procesnavn *>
system(6,0,processname);
ix:=2; pos:=0; more:=true;
repeat
char:=processname(ix) extract 8;
more:=char = 'nul' or ('0' <= char and char <= '9');
if more then
begin
pos:=pos + 1;
processname(ix):=processname(ix) shift(-8);
end;
if pos = 6 then
begin
pos:=0;
ix :=ix - 1;
end;
until -,more;
if ix = 2 and pos < 5 then
begin
processname(ix):=processname(ix) shift(8*pos - 40);
pos:=5;
end;
i:=0;
repeat
if pos = 0 then
begin
pos:=6;
ix :=ix + 1;
end;
i:=i + 1; pos:=pos - 1;
processname(ix):=
processname(ix) shift 8 add (if i <= 4 then (case i of ('p','a','c','k')) else 'nul');
until pos = 0 and i >= 4;
<* navnet returneres *>
for ix:=1,2 do la(ix):=processname(ix);
end gen_packname;
\f
procedure get_packfile(z,tail,opret);
<***********************************>
zone z ;
integer array tail ;
boolean opret ;
<*
proceduren åbner til packfile,
hvis den ikke findes og opret
er 'true', oprettes en ny
packfile med navnet 'xxxpack'
komponeret ud fra brugernavnet
*>
begin
procedure error(s,i,b);
<*********************>
string s ;
integer i ;
boolean b ;
begin
write(out,<:<10>packfile.:>,packfile);
if tail.device(1) <> empty
and tail.device(1) <> extend 1 shift 24
then write(out,<:.:>,tail.device);
break(s,i,b);
end error;
boolean procedure open_pack(name);
<********************************>
long array name ;
begin
integer r;
close(z,true);
open(z,4,name,0);
r:= monitor(42,z,0,tail);
if r = 0 and tail(1) <= 0 then
begin
long array field
_ doc;
doc:= 2;
tofrom(name,tail.doc,8);
close(z,true);
open(z,4,name,0);
r:= monitor(42,z,0,tail);
end;
if r <> 0 and r <> 3 then
monitor_error(42,z,r,true);
if r = 0 then
begin
if tail(9) <> 10 shift 12 add 1 then
error(<:*** file is no packfile, content key =:>,tail(9) shift(-12),true);
end;
open_pack:=if r = 0 then true else false;
end open_pack;
long array
_ la_help(1:2);
integer array
_ head_tail(1:17);
integer
_ waittime,
_ return;
boolean
_ search,
_ found;
long array field
_ device;
integer array field
_ iaf;
iaf :=0;
device:=2;
tail.device(1):= empty;
if packfile(1) = empty then
begin
search:=true;
gen_packname(la_help);
end
else search:=false;
if search then
begin
found:=open_pack(la_help);
if -,found then
begin
packfile(1):=long <:publi:> add 'c';
packfile(2):=long <:pack:> ;
found:=open_pack(packfile);
if -,found then
begin
packfile(1):=la_help(1);
packfile(2):=la_help(2);
close(z,true);
open (z,4,packfile,0);
end;
end
else
begin
packfile(1):=la_help(1);
packfile(2):=la_help(2);
end;
end
else found:=open_pack(packfile);
if -,found and opret then
begin
if packkit(1) = empty then get_permkit_name(packkit);
<* nødvendige størrelse beregnes *>
tail(1):= 1 +
_ (max_pack_entries - 1)//(512//pack_entry_length) + 1 +
_ (max_gap_entries - 1)//(512//4) + 1;
tail.device(1):=packkit(1);
tail.device(2):=packkit(2);
tail(6):=systime(7,0,0.0);
tail(7):=0;
tail(8):=0;
tail(9):=10 shift 12 + 1;
tail(10):=0;
return:=monitor(40,z,0,tail);
if return <> 0 then
begin
if return <> 4 then
monitor_error(40,z,return,false);
error(<:*** packfile cannot be created of segments:>,tail(1),true);
end;
monitor(42,z,0,tail);
write(out,<:<10>packfile.:>,packfile,<:.:>,tail.device,
_ <:, created of:>,tail(1),<: segments<10>:>);
<* packfilen tildeles scope = user *>
return:= monitor(50)permanent_entry:(z,3,tail);
if return = 0 then
begin
head_tail(1):= process_bases(5);
head_tail(2):= process_bases(6);
return:= monitor(74)set_entry_base:(z,0,head_tail);
if return <> 0 and return <> 3 then
monitor_error(74,z,return,false);
if return <> 0 then
monitor(50)temp_entry:(z,0,tail);
end
else
if return <> 6 then
monitor_error(50,z,return,false);
if return <> 0 then
write(out,"nl",1,<:*** packfile temporary, no perm resources<10>:>);
init_packfile(z,tail);
found:=true;
end
else
if -,found then
error(<:*** packfile does not exist:>,0,true);
return:=monitor(52)create_areaprocess:(z,0,tail);
if return <> 0 then monitor_error(52,z,return,true);
<* det undersøges om packfilen er en system packfil *>
return:= monitor(76)lookup_head_and_tail:(z,0,head_tail);
if return <> 0 then monitor_error(76,z,return,true);
system_packfile:=
if head_tail.key extract 3 = 3
and (head_tail.lower_base < process_bases(7) and head_tail.upperbase >= process_bases(8)
or head_tail.lower_base <= process_bases(7) and head_tail.upperbase > process_bases(8))
then true else false;
if system_packfile
and program_function <> unpacksym
and program_function <> pointpacksym
and program_function <> searchpacksym
then error(<:*** program function not allowed on system packfile !:>,0,true);
if scopeboo and system_packfile then
scopelist(systemscope):= true;
<* reservation af packfile *>
if -,system_packfile then
begin
trap(wait);
waittime:= 0;
for return:=monitor(8,z,0,tail)
while return = 1 do
begin <* wait for release *>
delay(max_timeinterval <* seconds *>);
waittime:= waittime + max_timeinterval;
if waittime >= maxwaittime then
begin
trap(0);
close(z,true);
error(<:*** waiting time for release of packfile exceeded, max. wait time =:>,maxwaittime,true);
end;
end;
trap(0);
if false then
wait:
begin
trap(0);
close(z,true);
error(<:*** time exceeded or user kill while waiting for release of packfile:>,0,true);
end;
if return <> 0 then monitor_error(8,z,return,true);
<* hovedet indlæses *>
swoprec6(z,512);
end
else
inrec6(z,512);
if z.entrylength < pack_entry_length then
error(<:*** packfile wrong version !<10> creation date =:>,z.creation_date,true);
end get_packfile;
<* der åbnes til packfile, ved pack oprettes denne evt. *>
get_packfile(head,pack_tail,
if program_function = packsym then true else false);
end procedure initialize_packfile;
\f
procedure main(ud,head);
<**********************>
zone ud,head ;
<* proceduren indeholder hele hovedprogrammet *>
<* bufferen 'ud' anvendes til kørselsoversigt *>
begin
procedure empty_out(z);
<*********************>
zone z ;
<*
tømmer den igangværende
blok efter tegnvis ud-
skrivning
*>
begin
integer array
_ descr(1:20);
integer
_ leftch,
_ pw;
getzone6(z,descr);
if descr(14) + 4*descr(20)//descr(18) > descr(15) then
begin
leftch:=(descr(15) - descr(14)) // 2 * 3;
pw := descr(12);
leftch:= leftch -
_ (if pw shift(-16) = 1 then 2 else
_ if pw shift(-8) extract 8 = 1 then 1 else 0);
outchar(z,'nl');
leftch:= leftch - 1;
if leftch < 0 then
leftch:= 768 - leftch;
write(z,false,leftch);
end;
end empty_out;
\f
procedure recompute_hashkeys(list);
<********************************>
boolean list ;
<*
proceduren gennemløber packcat, og
nyberegner hashnøglerne, såfremt
disse ikke er korrekte
*>
begin
integer
_ no,
_ h_help;
newposition(packcat,1,packcat_updated,packcat_leftblock);
for no:=1 step 1 until head.packentries do
begin
nextrecord(packcat,head.entrylength,packcat_updated,packcat_leftblock);
if packcat.key <> 0 then
begin
h_help:= compute_hashkey(packcat.entryname,packcat.password);
if packcat.hashkey <> h_help then
begin
packcat.hashkey:= h_help;
packcat_updated:= true ;
if list then
begin
print_entry(out,packcat.entrybase_adr,intern_bases,undefined,ownerlist);
write(out,"sp",5,<:*** hashkey recomputed:>);
end;
end;
end;
end packentries;
newposition(packcat,0,packcat_updated,packcat_leftblock);
if -,system_packfile and head.extend_mark <> 0 then
begin
head.extend_mark:= 0;
setposition(head,0,0);
swoprec6(head,512);
end;
<*+1*>
if test shift(-2) then write(out,<:<10><10>recompute hashkeys<10>:>);
<*-1*>
end recompute_hahskeys;
\f
boolean procedure check_packfile_head(z,tail);
<********************************************>
zone z ;
integer array tail ;
<*
undersøger indholdet af packfilens hovede
og sammenligner med oplysninger i tail,
hvis der er uoverensstemmelser markeres
at en nærmere undersøgelse af packfilen
bør gennemføres, hvilket kan være aktuelt
efter programfejl, programafbrydelse
eller system breakdown
returværdi = true, hvis der fandtes fejl.
*>
begin
check_packfile_head:=
if tail(1) <> z.packfile_size
or tail(7) <> z.no_of_entries
or tail(10)<> z.no_of_gaps
or tail(1) <> z.first_areasegm + z.no_of_segm + z.no_of_gapsegm
then true else false;
<* test af om repack er påkrævet *>
if program_function <> repacksym then
begin
if z.packentries - z.no_of_entries < round(0.1 * z.packentries) then
write(out,<:<10>*** repack required, free packentries less than:>,round(0.1 * z.packentries));
if z.gapentries - z.no_of_gaps < 10 then
write(out,<:<10>*** repack required, free gapentries less than 10:>);
end;
end check_packfile_head;
\f
boolean procedure check_catalogs(head,tail);
<******************************************>
zone head ;
integer array tail ;
<*
undersøger om der er fejl i katalogerne, og
om der er inkonsistens mellem packcataloget
og hulkataloget. hvis alt findes i orden
initialiseres antallet af indgange i de to
kataloger svarende til de registrerede værdier
i packfilens tail - såfremt disse stemmer overens
med det faktiske antal indgange.
returværdi = true, hvis fejl.
*>
begin
integer array
_ entry_table(1:head.packentries,1:3),
_ gap_table(1:head.gapentries,1:3);
integer
_ not_reg,
_ entry_used,
_ gap_used,
_ entry_segm,
_ gap_segm,
_ total_size;
boolean
_ hashkey_error,
_ pack_error,
_ gap_error,
_ cross_error;
\f
boolean procedure check_packcat(tab,used,segm,key_error);
<*******************************************************>
integer array tab ;
integer used,segm ;
boolean key_error ;
<*
undersøger packcataloget for evt. at afsløre fejl
i dette.
returværdi = true, hvis fejl.
*>
begin
procedure overskrift;
<*******************>
begin
first:= false;
write(out,"nl",3,
_ <:- - - errors in packcatalog - - -:>,"nl",1,
_ <:*********************************:>,"nl",2);
end;
integer
_ h_help,
_ no;
boolean
_ first;
check_packcat:= false;
key_error := false;
first := true ;
used := 0;
segm := 0;
total_size := head.first_areasegm;
newposition(packcat,1,packcat_updated,packcat_leftblock);
for no:=1 step 1 until head.packentries do
begin
nextrecord(packcat,head.entrylength,packcat_updated,packcat_leftblock);
if packcat.key <> 0 then
begin
used:= used + 1;
if packcat.area_size > 0 then
segm:= segm + packcat.area_size;
if packcat.entryindex <> no then
begin
check_packcat:= true;
if first then overskrift;
print_entry(out,packcat.entrybase_adr,intern_bases,undefined,statlist);
write(out,"nl",1,"sp",5,<:*** entry in wrong place =:>,<<ddddd>,no,
_ <:, right place is = :>,packcat.entryindex);
end;
<* test af hashkey *>
h_help:= compute_hashkey(packcat.entry_name,packcat.password);
if packcat.hashkey <> h_help then
begin
key_error:= true;
if first then overskrift;
print_entry(out,packcat.entrybase_adr,intern_bases,undefined,statlist);
write(out,"nl",1,"sp",5,<:*** wrong hashkey =:>,<<-ddddddd>,packcat.hashkey,
_ <:, hashkey should be =:>,h_help);
end;
<* initialisering af tabel *>
tab(used,1):= packcat.store_address;
if packcat.store_address > 0 then
tab(used,2):= packcat.store_address + packcat.area_size - 1
else
tab(used,2):= 0;
tab(used,3):= no;
if total_size < tab(used,2) + 1
then total_size:= tab(used,2) + 1;
if tab(used,2) > tail(1) then
begin
if first then overskrift;
print_entry(out,packcat.entrybase_adr,intern_bases,undefined,statlist);
write(out,"nl",1,"sp",5,<:*** area outside last segment of packfile:>);
end;
end key <> 0;
end packentries;
<*+1*>
if test shift(-2) then write(out,<:<10>check packcat, used/ segm::>,used,segm);
<*-1*>
end check_packcat;
\f
boolean procedure check_gapcat(gapcat,tab,used,segm);
<***************************************************>
zone gapcat ;
integer array tab ;
integer used,segm ;
<*
undersøger hulkataloget for evt. at afsløre
fejl i dette.
returværdi = true, hvis fejl.
*>
begin
procedure print_error(z);
<***********************>
zone z ;
begin
if first then
begin
first:= false;
write(out,"nl",3,
_ <:- - - errors in gapcatalog - - -:>,"nl",1,
_ <:********************************:>,"nl",2);
end;
write(out,"nl",1,
_ <:wrong gapcatalog entry =:>,<<-ddddddd>,no,
_ <:, first segment =:>,z(1) shift(-24) extract 24,
_ <:, no of segments =:>,z(1) extract 24);
end print_error;
integer
_ no;
boolean
_ first;
check_gapcat:= false;
first := true ;
used := 0 ;
segm := 0 ;
newposition(gapcat,head.gapcat_adr,gapcat_updated,gapcat_leftblock);
for no:=1 step 1 until head.gapentries do
begin
nextrecord(gapcat,4,gapcat_updated,gapcat_leftblock);
if gapcat.first_emptysegm > 0 then
begin
if gapcat.no_of_emptysegm > 0 then
begin
used:= used + 1;
tab(used,1):= gapcat.first_emptysegm;
tab(used,2):= gapcat.first_emptysegm + gapcat.no_of_emptysegm - 1;
tab(used,3):= no;
segm:= segm + gapcat.no_of_emptysegm;
if total_size < tab(used,2) + 1
then total_size:= tab(used,2) + 1;
end
else
begin
check_gapcat:= true;
print_error(gapcat);
end;
end
else
if gapcat.first_emptysegm < 0 then
begin
check_gapcat:= true;
print_error(gapcat);
end;
end gapentries;
newposition(gapcat,0,gapcat_updated,gapcat_leftblock);
<*+1*>
if test shift(-2) then write(out,<:<10>check gapcat, used/ segm::>,used,segm);
<*-1*>
end check_gapcat;
\f
boolean procedure check_crossref;
<*******************************>
begin
integer
_ i,
_ j;
boolean
_ first;
procedure overskrift;
<*******************>
begin
first:= false;
write(out,"nl",3,
_ <:- - - owerlap errors in catalogs or between catalogs - - -:>,"nl",1,
_ <:**********************************************************:>,"nl",2);
end overskrift;
<* sortering af tabellerne *>
if entry_used > 0 then
quicksort(entry_table,entry_used,3,1);
if gap_used > 0 then
quicksort(gap_table,gap_used,3,1);
check_crossref:= false;
first := true;
<* test af overlap i packcatalog *>
for i:= 1 step 1 until entry_used - 1 do
if entry_table(i,1) > 0 then
begin
if entry_table(i,2) >= entry_table(i+1,1) then
begin
check_crossref:= true;
if first then overskrift;
write(out,"nl",1,
_ <:area no. =:>,<<ddddd>,entry_table(i,3),
_ <:, owerlaps with area no. =:>,entry_table(i+1,3));
end;
end;
<* test af overlap i hulkatalog *>
for i:=1 step 1 until gap_used - 1 do
if gap_table(i,2) >= gap_table(i+1,1) then
begin
check_crossref:= true;
if first then overskrift;
write(out,"nl",1,
_ <:gap no. =:>,<<ddddd>,gap_table(i,3),
_ <:, owerlaps with gap no. =:>,gap_table(i+1,3));
end;
<* test af konsistens mellem de to kataloger *>
if entry_used > 0 and gap_used > 0 then
for i:=1 step 1 until entry_used do
if entry_table(i,1) > 0 then
begin
for j:=1 step 1 until gap_used do
if entry_table(i,1) <= gap_table (j,1)
and gap_table (j,1) <= entry_table(i,2)
or entry_table(i,1) <= gap_table (j,2)
and gap_table (j,2) <= entry_table(i,2) then
begin
check_crossref:= true;
if first then overskrift;
write(out,"nl",1,
_ <:area no. =:>,<<ddddd>,i,
_ <:, owerlaps with gap no. =:>,j);
end;
end konsistens check;
<*+1*>
if test shift(-2) then write(out,<:<10>check crossref:>);
<*-1*>
end check_crossref;
\f
check_catalogs:= false;
pack_error:= check_packcat(entry_table,entry_used,entry_segm,hashkey_error);
if gapcat_used then
gap_error:= check_gapcat(gapcat,gap_table,gap_used,gap_segm)
else
begin <* vi låner bufferen packcat ! *>
newposition(packcat,0,packcat_updated,packcat_leftblock);
gap_error:= check_gapcat(packcat,gap_table,gap_used,gap_segm);
end;
cross_error:= check_crossref;
<* nu gennemføres den afsluttende testning *>
if -,pack_error and -,gap_error and -,cross_error
and tail(1) = total_size
and tail(7) = entry_used
and tail(10) = gap_used then
begin
head.packfile_size := total_size;
head.no_of_entries := entry_used;
head.no_of_segm := entry_segm;
head.no_of_gaps := gap_used ;
head.no_of_gapsegm := gap_segm ;
if hashkey_error then
recompute_hashkeys(true);
write(out,"nl",3,<:- - - packfile reset - should be ok !:>,"nl",1);
end
else
begin
check_catalogs:= true;
write(out,"nl",3,<:- - - errors in dimensions of packfile - - -:>,"nl",1,
_ <:********************************************:>,"nl",2);
write(out,<< -ddddddddd>,
_ <:parameter actual value registered value registered value<10>:>,
_ <: accounted in entry-tail in packfile-head<10>:>,
_ <:========================================================================<10>:>,
_ <:<10>packfile size :>,total_size,tail(1),head.packfile_size,
_ <:<10>no of entries :>,entry_used,tail(7),head.no_of_entries,
_ <:<10>no of gaps :>,gap_used,tail(10),head.no_of_gaps,
_ <:<10>:>,
_ <:<10>no of segments :>,entry_segm,"sp",2,"-",16,head.no_of_segm,
_ <:<10>no of gapsegments :>,gap_segm,"sp",2,"-",16,head.no_of_gapsegm);
end;
not_reg:= tail(1) - head.first_areasegm - entry_segm - gap_segm;
if not_reg > 0 then
write(out,<:<10><10>* no of segments not registered in gapcat =:>,not_reg);
<*+1*>
if test shift(-2) then write(out,<:<10>check catalogs, not registered =:>,not_reg);
<*-1*>
end check_catalogs;
\f
procedure lookup_auxdoc(aux_name,rel_nametable_adr);
<**************************************************>
value rel_nametable_adr ;
long array aux_name ;
integer rel_nametable_adr ;
<*
finder for en katalogindgang uden tilknyttet areal
navnet på det aux. document, hvor denne findes i
det pågældende auxiliary catalog, dvs. permkey større
end min_auxcat_permkey ( = 2)
*>
begin
long array
_ aux_doc(1:2);
integer array
_ first_bsnametable_adr(1:1),
_ chaintable_adr(1:1);
<* hent nametable address for første drum chain *>
if system(5,92,first_bsnametable_adr) = 0
then system(9,0,<:<10>corecopy:>);
<* evt. hentes nametable address for første disc chain *>
if first_bsnametable_adr(1) = 0 then
begin
if system(5,94,first_bsnametable_adr) = 0
then system(9,0,<:<10>corecopy:>);
end;
<* nu hentes adressen på den relevante chain table *>
if system(5,first_bsnametable_adr(1) + rel_nametable_adr, chaintable_adr) = 0
then system(9,0,<:<10>corecopy:>);
<* nu hentes navnet på det ønskede document i chain table , rel. adr. = -18 *>
if system(5,chaintable_adr(1) - 18,aux_doc) = 0
then system(9,0,<:<10>corecopy:>);
aux_name(1):= aux_doc(1); aux_name(2):= aux_doc(2);
end lookup_auxdoc;
\f
integer procedure lookup_entry(entry,bases,name,scope);
<*****************************************************>
integer array entry,bases ;
long array name ;
integer scope ;
<*
søger katalogindgangen specificeret ved 'name'
og 'scope' i main-catalog
returværdi:
-1: entry findes ikke med det angivne scope
0: entry findes
1: entry med tilhørende areal findes
*>
begin
zone
_ look(1,1,stderror);
integer array
_ catbase(1:2);
integer
_ return,
_ helpscope,
_ lower_index,
_ upper_index;
if scope > login and scope <> undefined then
begin
lower_index:=case scope + 1 of (3,3,5,7,7);
upper_index:=case scope + 1 of (4,4,6,8,8);
<* katalogbaser ændres med hensyn til scope *>
catbase(1):=bases(lower_index);
catbase(2):=bases(upper_index);
return:=monitor(72)set_cat_base:(myself,0,catbase);
if return <> 0 then monitor_error(72,myself,return,true);
end;
open(look,0,name,0);
return:=monitor(76)lookup_head_and_tail:(look,0,entry);
if return <> 0 and return <> 3 then
monitor_error(76,look,return,true);
close(look,true);
if return = 0 then
begin
helpscope:=entry_scope(entry,bases);
if scope = undefined and helpscope < systemscope and helpscope <> undefined
then scope:=helpscope;
lookup_entry:=
if scope = helpscope and helpscope <> undefined
then (if entry.areasize >= 0 then 1 else 0)
else -1;
<*+1*>
if test shift(-2) then
begin
print_entry(out,entry,bases,helpscope,normlist);
write(out,<:, lookup:>);
end;
<*-1*>
end
else lookup_entry:= -1;
if scope > login and scope <> undefined then
begin
<* katalogbaserne sættes tilbage til standard *>
return:=monitor(72)set_cat_base:(myself,0,bases);
if return <> 0 then monitor_error(72,myself,return,true);
end;
end lookup_entry;
\f
boolean procedure search_catalogentry(catalog,entry,bases,scope);
<***************************************************************>
zone catalog ;
integer array entry,bases ;
integer scope ;
<*
søger frem i main catalog for at finde entries, som opfylder
udvælgelseskriterier angivet ved scope eller subtext
returværdi = true sålænge der findes flere entries i main catalog
*>
begin
own integer
_ catalogentries,
_ entryno;
integer
_ no;
boolean
_ found;
long array field
_ subname;
if catalogentries = 0 then
begin
integer array
_ tail(1:10);
no:=monitor(42)lookup_entry:(catalog,0,tail);
if no <> 0 then monitor_error(42,catalog,no,true);
catalog_entries:= 512//34 * tail(1);
end;
found:= false;
repeat
inrec6(catalog,34);
entryno:=entryno + 1;
if catalog.key <> -1 then
begin
<*
det undersøges om entry er synlig for processen
og er indeholdt i processens max. baser
*>
if extend catalog.lowerbase <= lower_catbase and extend catalog.upperbase >= upper_catbase
and extend catalog.lowerbase >= bases(7) and extend catalog.upperbase <= bases(8) then
begin
<*+1*>
if test shift(-4) then
begin
print_entry(out,catalog.entrybase_adr,bases,undefined,normlist);
write(out,<:, search main catalog:>);
end;
<*-1*>
if scopeboo then
begin
scope:=entry_scope(catalog.entry_baseadr,bases);
if scope <> undefined then
found:=scopelist(scope);
end;
if -,found and no_of_subtext > 0 then
begin
subname:= subtext_adr;
for no:=1, no + 1 while no <= no_of_subtext and -,found do
begin
found:=subcompare(catalog.entryname,optionlist.subname);
subname:=subname + 12;
end;
end;
end synlig;
end catalogkey <> -1;
until found or entryno = catalog_entries;
if found and -,scopeboo then
scope:=entry_scope(catalog.entry_baseadr,bases);
if found then
tofrom(entry,catalog.entry_baseadr,34);
search_catalogentry:=found;
<*+1*>
if test shift(-2) and found then
begin
print_entry(out,entry,bases,scope,normlist);
write(out,<:, search catalogentry:>);
end;
<*-1*>
end search_catalogentry;
\f
procedure lookup_error(ud,la,scope,intern,type);
<**********************************************>
value scope,intern,type ;
zone ud ;
long array la ;
integer scope, type ;
boolean intern ;
<*
udskriver fejlmeddelelse når entry ikke findes
*>
begin
outchar(ud,'nl');
write(ud,"sp",44 - write(ud,la));
if scope <> undefined then
write(ud,"sp",24 -
write(ud,case scope + 1 of (<:temp:>,<:login:>,<:user:>,
_ <:project:>,<:system:>)))
else
write(ud,"sp",24);
if intern then
write(ud,"sp",11 - write(ud,ownerid))
else
write(ud,"sp",11);
write(ud,"sp",5,case type of (
_ <:*** entry not found:>,
_ <:*** entryname reserved:>)
);
end lookup_error;
\f
integer procedure print_date(z,short);
<************************************>
value short ;
zone z ;
integer short ;
<* udskriver dato og klokkeslet fra shortclock *>
begin
integer
_ date;
real
_ clock;
date:= systime(6,short,clock);
print_date:=
write(z,<:d.:>,<<dddddd>,date,<:.:>,<<zddd>,clock/100);
end print_date;
\f
procedure print_head_and_tail(z,entry,bases,scope);
<*************************************************>
zone z ;
integer array entry,bases ;
integer scope ;
<*
udskriver head og tail for <entry>
*>
begin
integer
_ i;
write(z,"sp",13 - write(z,"nl",1,entry.entryname),<:=set:>);
if entry.areasize >= 0 then
write(z,entry.areasize)
else
write(z,entry.areasize shift(-12),<:.:>,<<d>,entry.areasize extract 12);
write(z,"sp",1,entry.documentname);
i:= 6;
if entry.entrytail(i-5) <> 0
and entry.entrytail(4) shift(-12) <> 4
and entry.entrytail(4) shift(-12) < 32 then
begin
outchar(z,'sp');
print_date(z,entry.entrytail(i-5));
i:= i + 1;
end;
for i:= i step 1 until 10 do
if entry.entrytail(i-5) = 0 then
write(z,<: 0:>)
else
write(z,entry.entrytail(i-5) shift (-12),
_ <:.:>,<<d>,entry.entrytail(i-5) extract 12);
write(z,<: ; :>,case (if scope = undefined then entry_scope(entry,bases) else scope) + 1
_ of (<:temp:>,<:login:>,<:user:>,<:project:>,<:system:>,<:***:>));
if entry.auxdocname(1) <> empty then write(z,<:.:>,entry.auxdocname);
if entry.password(1) <> empty then write(z,<:.:>,entry.password);
write(z,"nl",1,"sp",12,<:; :>,entry.key shift(-12),
_ entry.key extract 12 shift(-3),entry.key extract 3,
_ entry.lowerbase,entry.upperbase);
end print_head_and_tail;
\f
integer procedure print_modekind(z,modekind);
<*******************************************>
value modekind ;
zone z ;
integer modekind ;
begin
integer
_ mode,
_ kind,
_ codeix,
_ modeix;
kind:= modekind extract 12;
mode:= modekind shift (-12) extract 11;
modeix:= mode//2 + 1;
codeix:= if kind <= 20 and mode <= 10 then
(case kind//2 + 1 of (
<* kind/mode *>
<* 0 *> case modeix of ( 1, 0, 0, 0, 0, 0),
<* 2 *> case modeix of ( 0, 0, 0, 0, 0, 0),
<* 4 *> case modeix of ( 2, 0, 0, 0, 0, 0),
<* 6 *> case modeix of ( 0, 0, 0, 0, 0, 0),
<* 8 *> case modeix of ( 3, 0, 0, 0, 0, 0),
<* 10 *> case modeix of ( 4, 5, 6, 7, 0, 0),
<* 12 *> case modeix of ( 8, 9,10,11,12, 0),
<* 14 *> case modeix of (13, 0, 0, 0, 0, 0),
<* 16 *> case modeix of (14, 0, 0, 0,15,16),
<* 18 *> case modeix of (17,18,19,20, 0, 0),
<* 20 *> case modeix of (21, 0, 0, 0, 0, 0),
0)) else 0;
print_modekind:=
if codeix > 0 then
write(z,case codeix of (
_ <:ip:>,<:bs:>,<:tw:>,<:tro:>,<:tre:>,
_ <:trn:>,<:trf:>,<:tpo:>,<:tpe:>,<:tpn:>,
_ <:tpf:>,<:tpf:>,<:lp:>,<:crb:>,<:crd:>,
_ <:crc:>,<:mto:>,<:mte:>,<:nrz:>,<:nrze:>,
_ <:pl:>))
else
write(z,<<dddd>,mode,<:.:>,<<d>,kind);
end print_modekind;
\f
procedure print_entry(z,entry,bases,scope,type);
<**********************************************>
value scope,type ;
zone z ;
integer array entry,bases ;
integer scope,type ;
<*
udskriver oplysninger for en katalogingang på
zonen <z> afhængig af værdien af <type>.
type:
1: kun katalogindgangens første del udskrives
2: endvidere udskrives owner
3: owner, samt statistik delen udskrives
*>
begin
integer
_ k;
real
_ clock;
real array field
_ raf;
raf:= 0;
if scope = undefined then
scope:= entry_scope(entry,bases);
outtext(z,-12,entry.entryname.raf,1);
if entry.areasize >= 0 then
write(z,<< dddddddd>,entry.areasize)
else
write(z,"sp",9 - print_modekind(z,entry.areasize));
k:=
write(z,"sp",3,entry.documentname);
write(z,"sp",23 - (if entry.areasize < 0 then
write(z,<:.:>,true,22 - k,entry.auxdocname) + k else k));
write(z,"sp",9 - write(z,case scope + 1 of
_ (<:temp:>,<:login:>,<:user:>,
_ <:project:>,<:system:>,<:***:>)));
if entry.entrytail(1) <> 0
and entry.entrytail(4) shift (-12) <> 4
and entry.entrytail(4) shift (-12) < 32
then
write(z,<:d.:>,<<dddddd.dddd>,
_ systime(6,entry.entrytail(1),clock)
_ + clock/1000000,"sp",2)
else
write(z,"sp",15);
if type = 2 or type = 3 then
outtext(z,11,entry.password.raf,1)
else
write(z,"sp",11);
if type = 3 then
write(z,"sp",1,<< dddddd>,
_ entry.packdate,
_ entry.last_accessdate,
_ entry.no_of_read,
_ entry.no_of_point,
_ entry.storeaddress);
end print_entry;\f
procedure print_heading(z,type);
<******************************>
zone z ;
integer type ;
begin
write(z,"nl",1,case type of (
<:NAME KIND/SIZE DOCUMENT SCOPE DATE:>,
<:NAME KIND/SIZE DOCUMENT SCOPE DATE OWNER:>,
<:NAME KIND/SIZE DOCUMENT SCOPE DATE OWNER PACKDATE ACCESS READS POINT SEGMNO:>,
<::>),"nl",1);
end heading;
\f
<*+2*>
procedure print_packhead(z);
<**************************>
zone z ;
<* udskriver packfilens filhovede *>
begin
integer array field
_ iaf;
iaf := 0;
setposition(z,0,0);
inrec6(z,512);
write(out,"ff",1,"nl",1,<:contents of packfilehead:>,"nl",2);
write(out,<<ddddddddd>,
_ <:<10>packentry length ::>,z.iaf(1),
_ <:<10>max packentries ::>,z.iaf(2),
_ <:<10>---------------------::>,z.iaf(3),
_ <:<10>max gapentries ::>,z.iaf(4),
_ <:<10>---------------------::>,z.iaf(5),
_ <:<10>gapcatalog adr ::>,z.iaf(6),
_ <:<10>first areasegm ::>,z.iaf(7),
_ <:<10>no of entries ::>,z.iaf(8),
_ <:<10>no of segm ::>,z.iaf(9),
_ <:<10>no of gaps ::>,z.iaf(10),
_ <:<10>no of gapsegm ::>,z.iaf(11),
_ <:<10>retention days ::>,z.iaf(12),
_ <:<10>last update ::>,z.iaf(13),
_ <:<10>packfile size ::>,z.iaf(14),
_ <:<10>creation date ::>,z.iaf(15),
_ <:<10>update mark ::>,z.iaf(16),
_ <:<10>hashtable size ::>,z.iaf(17),
_ <:<10>last function ::>,z.iaf(18),
_ <:<10>extend mark ::>,z.iaf(19),
<::> );
end print_packhead;
\f
procedure print_packcat(cat);
<***************************>
zone cat ;
<*
udskriver hele packfilens katalog
*>
begin
integer
_ no;
write(out,"ff",1,"nl",1,<:contents of packcatalog:>,"nl",2);
print_heading(out,3);
setposition(cat,0,1);
for no:=1 step 1 until head.packentries do
begin
inrec6(cat,head.entrylength);
if cat.key <> 0 then
print_entry(out,cat.entry_baseadr,intern_bases,undefined,statlist)
else write(out,"nl",1,<:------------:>,"sp",103);
write(out,<<ddddd>,no);
end;
end print_packcat;
\f
procedure print_gapcat(gap);
<**************************>
zone gap ;
<*
udskriver indholdet af hulkataloget
*>
begin
integer
_ no;
write(out,"ff",1,"nl",1,<:contents of gapcatalog:>,"nl",2);
write(out,<:<10>firstsegm segm entryno<10>:>);
setposition(gap,0,head.gapcat_adr);
for no:=1 step 1 until head.gapentries do
begin
inrec6(gap,4);
if gap.first_emptysegm <> 0 then
write(out,"nl",1,<<dddddddd>,gap.first_emptysegm,gap.no_of_emptysegm,no)
else
write(out,"nl",1,<<dddddddd>,"-",16,no);
end;
end print_gapcat;
<*-2*>
\f
<*+2*>
procedure print_tables;
<*********************>
<* udskriver indholdet af hashtable og linktable *>
begin
integer
_ ix,
_ collisions,
_ chain_count,
_ max_chain,
_ ix1;
write(out,<:<12><10><10>contents of hashtables<10>:>);
collisions:= 0;
max_chain := 0;
for ix:=1 step 1 until head.hashtable_size do
begin
write(out,"nl",1,<<ddddddddd>,ix,hashtable(ix) extract 12);
if ix <= head.packentries then
begin
write(out,<<ddddddddd>,linktable(ix) extract 12);
if linktable(ix) extract 12 <> nil
and linktable(ix) extract 12 <> free
then collisions:= collisions + 1;
end;
if hashtable(ix) extract 12 <> nil then
begin
chain_count:= 0;
ix1:= hashtable(ix) extract 12;
while ix1 <> nil do
begin
chain_count:= chain_count + 1;
ix1:= linktable(ix1) extract 12;
end;
if chain_count > max_chain
then max_chain:= chain_count;
end;
end hashtable;
write(out,"nl",2,
_ <:<10>no of collisions =:>,collisions,
_ <:<10>longest chain sequence =:>,max_chain);
end print_tables;
<*-2*>
\f
procedure testblok(z,s,b);
<************************>
zone z ;
integer s,b ;
<*
anvendes til test af transporter
*>
begin
<*+2*>
integer array
_ zdescr(1:20),
_ sh_descr(1:12);
real array field
_ zname;
zname:= 2;
if s shift(-1) extract 1 = 1 then
begin <* normal answer *>
getzone6(z,zdescr);
getshare6(z,sh_descr,zdescr(17));
if sh_descr(7) <= blocktable_size then
begin
transfer_table(sh_descr(7),zdescr(13) - 4) :=
transfer_table(sh_descr(7),zdescr(13) - 4) + 1;
end;
bloktransfer:= bloktransfer + 1;
end
else
<*-2*>
stderror(z,s,b);
end testblok;
\f
integer procedure entry_scope(entry,bases);
<*****************************************>
integer array entry,bases ;
<*
finder scope på katalogindgang beskrevet i tail
på grundlag af processens baser
returværdi:
0 : temp
1 : login
2 : user
3 : project
4 : system
5 : undefined
*>
begin
long
_ lower_base,
_ upper_base;
lower_base:=entry(2);
upper_base:=entry(3);
case entry(1) extract 3 + 1 of
begin
<* permkey = 0, maybee temp *>
entry_scope:=
if lower_base = extend bases(3)
and upper_base = extend bases(4)
then 0
else 5;
<* permkey = 1, undefined *>
entry_scope:=5;
<* permkey = 2, maybee login *>
entry_scope:=
if lower_base = extend bases(3)
and upper_base = extend bases(4)
then 1
else 5;
<* permkey = 3, maybee user, project or system *>
entry_scope:=
if lower_base = extend bases(5)
and upper_base = extend bases(6)
then 2
else
if lower_base = extend bases(7)
and upper_base = extend bases(8)
then 3
else
if lower_base <= extend bases(7)
and upper_base >= extend bases(8)
then 4
else 5;
end case;
end entry_scope;
\f
boolean procedure open_special(z,doc,bases,scope,pos);
<****************************************************>
value scope,pos ;
zone z ;
long array doc ;
integer array bases ;
integer scope,pos ;
<*
åbner z til baggrundslager område med givet scope
*>
begin
integer array
_ dummy(1:12),
_ catbase(1:2);
integer
_ return,
_ lower_index,
_ upper_index;
if scope > login then
begin
lower_index:=case scope + 1 of (3,3,5,7,7);
upper_index:=case scope + 1 of (4,4,6,8,8);
<* katalogbaser ændres med hensyn til scope *>
catbase(1):=bases(lower_index);
catbase(2):=bases(upper_index);
return:=monitor(72)set_cat_base:(myself,0,catbase);
if return <> 0 then monitor_error(72,myself,return,true);
end;
<*
zonen åbnes til området, zonestate = after open
arealprocess oprettes og området reserveres,
og nametable address initialiseres
*>
open(z,4,doc,0);
open_special:= true;
return:= monitor(52)create_area_process:(z,0,catbase);
if return <> 0 then
begin
open_special:= false;
if return <> 3 then
monitor_error(52,z,return,true);
end
else
begin
return:= monitor(8)reserve_process:(z,0,catbase);
if return <> 0 then
begin
open_special:= false;
if return <> 1 then
monitor_error(8,z,return,true);
end
else
begin
monitor(16)send_message:(z,1,dummy);
monitor(18)wait_answer_:(z,1,dummy);
setposition(z,0,pos);
end;
end;
<*+1*>
if test shift(-2) then
write(out,<:<10>openspecial, :>,doc,<:, scope :>,scope,
_ "sp",3,if return = 0 then <:ok:> else <:not ok:>);
<*-1*>
<* katalogbaserne sættes tilbage til standard *>
if scope > login then
begin
return:=monitor(72)set_cat_base:(myself,0,bases);
if return <> 0 then monitor_error(72,myself,return,true);
end;
end open_special;
\f
boolean procedure change_scope(z,kit,bases,newscope);
<***************************************************>
value newscope ;
zone z ;
integer array kit,bases ;
integer newscope ;
<*
ændrer scope på katalogindgang eller baggrundslagerområde
knyttet til zonen 'z' til 'newscope'
*>
begin
integer array
_ entry_base(1:2);
integer
_ return,
_ lower_index,
_ upper_index,
_ catalog_key;
boolean
_ success;
success:=true;
catalog_key:=case newscope + 1 of (0,2,3,3);
lower_index:=case newscope + 1 of (3,3,5,7);
upper_index:=case newscope + 1 of (4,4,6,8);
entry_base(1):=bases(lower_index);
entry_base(2):=bases(upper_index);
return:=monitor(90)permanent_entry_in_aux_cat:(z,catalog_key,kit);
if return <> 0 then
begin
success:=false;
if return <> 2 and return <> 5 and return <> 6 then
monitor_error(50,z,return,true);
end
else
begin
return:=monitor(74)set_entry_base:(z,0,entry_base);
if return <> 0 then
begin
success:=false;
if return <> 3 then
monitor_error(74,z,return,true);
end;
end;
change_scope:=success;
end change_scope;
\f
integer procedure create_entry(entry,newkit,bases,scope);
<*******************************************************>
value scope ;
integer array entry, bases ;
long array newkit ;
integer scope ;
<*
opretter en katalogindgang svarende til entry_tail,
samt et tilhørende baggrundslagerområde
med det specificerede 'scope'
create_entry, result =
-2 : name conflict
-1 : no resources
0 : creation ok
1 : temp, no login resources
*>
begin
zone
_ z(if entry(8) >= 0 then 128 else 1,1,stderror);
integer array
_ ia(1:20),
_ name,
_ kit(1:4),
_ tail(1:10),
_ catbase(1:2);
integer
_ result,
_ return,
_ lower_index,
_ upper_index,
_ catalog_key;
boolean
_ success;
integer array field
_ doc_name,
_ entry_name,
_ tail_base;
integer field
_ size;
entry_name:=6;
tail_base :=14;
size :=16;
doc_name :=16;
success := true;
result := 0;
<* bestemmelse af det relevante documentnavn *>
if newkit(1) <> empty then
begin
if entry.size >= 0 then
tofrom(entry.doc_name,newkit,8);
tofrom(kit,newkit,8);
end
else
begin
if entry.size >= 0 then
tofrom(kit,entry.doc_name,8)
else
tofrom(kit,entry.auxdocname,8);
end;
tofrom(tail,entry.tailbase,20);
tofrom(name,entry.entryname,8);
if scope > login then
begin
<* oprettelse af entry med baser forskellige fra std. baser *>
open(z,if entry.size >= 0 then 4 else 0,<::>,0);
return:=monitor(40)create_entry:(z,0,tail);
if return <> 0 then
begin
success:=false;
result := -1;
if return <> 2 and return <> 4 then
monitor_error(40,z,return,true);
end
else
begin
if change_scope(z,kit,bases,scope) then
begin
return:=monitor(46)rename_entry:(z,0,name);
if return = 3 then
begin
success:=false;
result := -2;
end
else
if return <> 0 then monitor_error(46,z,return,true);
end
else
begin
success:=false;
result := -1;
end;
if -,success then
begin
return:=monitor(48)remove_entry:(z,0,tail);
if return <> 0 then monitor_error(48,z,return,true);
end;
end;
end
else
begin
<* opretttelse af entry med std. baser *>
open(z,if entry.size >= 0 then 4 else 0,entry.entryname,0);
return:=monitor(40)create_entry:(z,0,tail);
<* en evt. eksisterende entry fjernes, hvis areal skal oprettes *>
if return = 3 and entry.size >= 0 then
begin
return:=monitor(76)lookup_head_and_tail:(z,0,ia);
if return <> 0 then monitor_error(76,z,return,true);
return:=monitor(48)remove_entry:(z,0,ia);
if return <> 0 and return <> 5 then
monitor_error(48,z,return,true);
return:=monitor(40)create_entry:(z,0,tail);
end;
if return <> 0 then
begin
success:=false;
result := if return = 3 then (-2) else (-1);
if return <> 2 and return <> 3 and return <> 4 then
monitor_error(40,z,return,true);
end;
if scope = login and success then
begin
catalog_key:= 2;
return:=monitor(90)permanent_entry_in_aux_cat:(z,catalog_key,kit);
if return <> 0 then
begin
result:= 1;
if return <> 2 and return <> 5 and return <> 6 then
monitor_error(50,z,return,true);
end;
end;
end;
close(z,true);
create_entry:= result;
<*+1*>
if test shift(-2) then write(out,<:<10>create_entry, result = :>,<<-dd>,result);
<*-1*>
end create_entry;
\f
procedure newposition(z,segmno,updated,length);
<*********************************************>
value segmno ;
zone z ;
integer segmno, length ;
boolean updated ;
<*
tilbageskriver et opdateret segment
efter brug af inrec6 (= swoprec6)
*>
begin
integer
_ akt_segmno;
getposition(z,0,akt_segmno);
if segmno = -1 <* næste blok *> then
segmno:= akt_segmno + 1;
<*+1*>
if test shift(-2) then
write(out,<:<10>newposition, segmno =:>,segmno,<:, akt. segmno =:>,akt_segmno,
_ if updated then <:, updated:> else <:, not updated:>);
<*-1*>
if akt_segmno > 0 then
begin
if segmno <> akt_segmno then
begin
if updated then
begin <* blokken tilbageskrives *>
updated:= false;
setposition(z,0,akt_segmno);
outrec6(z,512);
setposition(z,0,segmno);
<* packfilens tail opdateres *>
if akt_segmno < head.gapcat_adr then
set_packtail(head,packtail,1)
else
set_packtail(head,packtail,2);
end
else
setposition(z,0,segmno);
end
else
begin <* recordbase sættes tilbage til bufferbase *>
integer array
_ zdescr(1:20);
getzone6(z,zdescr);
zdescr(14):= zdescr(15) - 4*zdescr(20)//zdescr(18);
zdescr(16):= 0;
setzone6(z,zdescr);
end;
end
else
setposition(z,0,segmno);
length:= 512;
end newposition;
\f
integer procedure nextrecord(z,length,updated,lbytes);
<****************************************************>
value length ;
zone z ;
integer length, lbytes ;
boolean updated ;
<* læser næste record og skifter blok om nødvendigt *>
begin
if length > lbytes then
newposition(z,-1 <* næste blok *>,updated,lbytes);
nextrecord:= inrec6(z,length);
lbytes:= lbytes - length;
<*+1*>
<*
if test shift(-2) then
write(out,<:<10>nextrecord, length =:>,<<ddddd>,length,
_ <:, leftbytes =:>,lbytes);
*>
<*-1*>
end nextrecord;
\f
procedure find_record(z,startsegm,recordno,length,updated,leftblock);
<*******************************************************************>
value startsegm,recordno,length ;
zone z ;
integer startsegm,recordno,length, leftblock ;
boolean updated ;
begin
integer array
_ zdescr(1:20);
integer
_ entries_pr_segm,
_ act_pos,
_ pos,
_ left;
entries_pr_segm:= 512//length;
pos := (recordno - 1) // entries_pr_segm + startsegm;
left := (recordno - 1) mod entries_pr_segm;
getposition(z,0,act_pos);
if pos <> act_pos then
begin
newposition(z,pos,updated,leftblock);
inrec6(z,0);
end;
getzone6(z,zdescr);
zdescr(14):= zdescr(15) - 4*zdescr(20)//zdescr(18) + left*length;
zdescr(16):= length;
setzone6(z,zdescr);
leftblock:= 512 - (left + 1) * length;
<*+1*>
if test shift(-2) then
write(out,<:<10>find record, entryno =:>,<<dddddd>,recordno,<:, pos =:>,pos,
_ <:, left =:>,left,<:, leftblock =:>,leftblock);
<*-1*>
end find_record;
\f
procedure swop_cat(packcat,packcat_updated,gapcat,gapcat_updated);
<****************************************************************>
zone packcat, gapcat ;
boolean packcat_updated, gapcat_updated ;
<*
tilbageskriver katalogsegmenter for at opnå veldefinerede
recovery punter i packfilen under opdatering, så genstart er mulig
*>
begin
integer array
_ zdescr(1:20);
integer
_ pos;
if packcat_updated then
begin
getposition(packcat,0,pos);
getzone6(packcat,zdescr);
setposition(packcat,0,pos);
outrec6(packcat,512);
packcat_updated:= false;
outrec6(packcat,0);
setzone6(packcat,zdescr);
set_packtail(head,packtail,1);
<*+1*> if test shift(-2) then
<*-1*> write(out,<:<10>swop packcat segm =:>,pos);
end;
if gapcat_updated then
begin
getposition(gapcat,0,pos);
getzone6(gapcat,zdescr);
setposition(gapcat,0,pos);
outrec6(gapcat,512);
gapcat_updated:= false;
outrec6(gapcat,0);
setzone6(gapcat,zdescr);
set_packtail(head,packtail,2);
<*+1*> if test shift(-2) then
<*-1*> write(out,<:<10>swop gapcat segm =:>,pos);
end;
end swop_cat;
\f
procedure set_packtail(z,tail,type);
<**********************************>
zone z ;
integer array tail ;
integer type ;
<*
gemmer forskellige oplysninger
i packfilens entry tail
type = 0: kun opdatering af packfile size
type = 1: opdatering af packcat
type = 2: opdatering af gapcat
type = 3: samtidig opdatering af begge kataloger
*>
begin
integer
_ return;
tail(1):=z.packfile_size;
tail(6):=systime(7,0,0.0);
if type = 1 or type = 3 then
begin
tail(7):=z.no_of_entries;
tail(8):=0;
end;
if type = 2 or type = 3 then
tail(10):=z.no_of_gaps;
return := monitor(44)change_entry:(z,0,tail);
if return <> 0 then
monitor_error(44,z,return,true);
end set_packtail;
\f
procedure check_transfer(z,updated);
<*********************************>
zone z ;
boolean updated ;
begin
integer array
_ zdescr(1:20),
_ shdescr(1:12);
getzone6(z,zdescr);
getshare6(z,shdescr,zdescr(17));
if zdescr(13) = 6 <* after outrec6 *> then
begin
if shdescr(1) <> 0 <* free share *>
and shdescr(1) <> 1 <* ready share *>
then
begin <* repeat output *>
zdescr(9):= zdescr(9) - 1;
setzone6(z,zdescr);
updated:= true;
write(out,<:<10>*** warning transfer repeated, segno =:>,zdescr(9));
end
else
if zdescr(16) > 0 then
begin
zdescr(9):= zdescr(9) - 1;
setzone6(z,zdescr);
end;
end;
<*+1*>
if test shift(-2) then
write(out,<:<10>check transfer, after repair:>,
_ <:<10>segm count =:>,zdescr(9),
_ <:<10>zonestate =:>,zdescr(13),
_ <:<10>sharestate =:>,shdescr(1),
_ <:<10>recordlength =:>,zdescr(16));
<*-1*>
end check_transfer;
\f
boolean procedure
_ movearea(toarea,topos,toscope,fromarea,frompos,fromscope,bufsegm,segm);
<*******************************************************************************>
value topos,toscope, frompos,fromscope,bufsegm,segm ;
long array toarea, fromarea ;
integer topos,toscope, frompos,fromscope,bufsegm,segm ;
begin
procedure flip;
begin
getzone6(buf,fromdescr);
setzone6(buf, todescr);
end;
procedure flop;
begin
getzone6(buf, todescr);
setzone6(buf,fromdescr);
end;
zone
_ buf(128 * (if bufsegm > segm then segm else bufsegm),1,stderror);
integer array
_ todescr,
_ fromdescr(1:20);
integer
_ bufsize,
_ segmcount;
boolean
_ ok1,
_ ok2;
ok1:= ok2:= true;
<*+1*>
if test shift(-2) then
write(out,<:<10>movearea, :>,toarea,<<dddd>,topos,"sp",3,fromarea,frompos,
_ <:, bufsegm =:>,bufsegm,<:, segm =:>,segm);
<*-1*>
if toscope = undefined then
begin
open(buf,4,toarea,0);
setposition(buf,0,topos);
end
else
ok1:= open_special(buf,toarea,process_bases,toscope,topos);
getzone6(buf,todescr);
close(buf,false);
if fromscope = undefined then
begin
open(buf,4,fromarea,0);
setposition(buf,0,frompos);
end
else
ok2:= open_special(buf,fromarea,process_bases,fromscope,frompos);
getzone6(buf,fromdescr);
if ok1 and ok2 then
begin
if bufsegm > segm then bufsegm:=segm;
bufsize:=bufsegm * 512;
segmcount:=0;
repeat
segmcount:=segmcount + bufsegm;
if segmcount > segm then
bufsize:=(segm - segmcount + bufsegm) * 512;
inrec6 (buf,bufsize); flip;
outrec6(buf,bufsize);
outrec6(buf, 0); flop;
<*+1*>
if test shift(-3) then
begin
datatransfer:= datatransfer + 2;
segmtransfer:= segmtransfer + 2 * bufsize // 512;
end;
<*-1*>
until segmcount >= segm;
end ok;
close(buf,true); flip;
close(buf,true); flop;
movearea:= ok1 and ok2;
end movearea;
\f
integer procedure compute_hashkey(name,owner);
<********************************************>
long array name,owner ;
<*
beregner hashkey på grundlag af name og owner,
dvs. opslagsnøglen til hashtabellen
*>
begin
long
_ keylong;
integer
_ keyint;
keylong:= name(1) + name(2) + owner(1) + owner(2);
keyint := keylong shift(-24) extract 24 +
_ keylong extract 24 ;
keyint := keyint shift(-12) + keyint extract 12;
compute_hashkey:= keyint mod head.hashtable_size + 1;
<*+1*>
if test shift(-2) then
write(out,<:<10>hashkey =:>,keyint mod head.hashtable_size + 1);
<*-1*>
end compute_hashkey;
\f
procedure initialize_hashtables(cat);
<***********************************>
zone cat ;
<*
proceduren initialiserer hashtable og
linktable ved et gennemløb af packfilens
entry katalog
*>
begin
integer
_ linkix,
_ ix;
<* defaultværdierne initialiseres *>
nil := 0;
free:= 4095;
<* tabellerne start-initialiseres *>
for ix:=1 step 1 until head.hashtable_size
do hashtable(ix):= false add nil;
for ix:=1 step 1 until head.packentries
do linktable(ix):= false add free;
setposition(cat,0,1);
for ix:=1 step 1 until head.packentries do
begin
inrec6(cat,head.entrylength);
if cat.key <> 0 then
begin
if hashtable(cat.hashkey) extract 12 = nil then
begin
hashtable(cat.hashkey):= false add ix;
linktable(ix) := false add nil;
end
else
begin
linkix:= hashtable(cat.hashkey) extract 12;
while linktable(linkix) extract 12 <> nil
do linkix:= linktable(linkix) extract 12;
linktable(linkix):= false add ix;
linktable(ix) := false add nil;
end;
<*+1*>
if test shift(-2) then
write(out,<:<10>initialize hashtables, hashkey =:>,<<ddddd>,cat.hashkey,
_ <:, index =:>,ix,<:, entryindex =:>,cat.entryindex);
<*-1*>
end key <> 0;
end genneløb af katalog;
setposition(cat,0,0);
end initialize hashtables;
\f
integer procedure insert_tableentry(cat,name,owner,hkey);
<******************************************************>
value hkey ;
zone cat ;
long array name,owner ;
integer hkey ;
<*
indsætter hashnøglen svarende til name og owner
i <entry>, finder en ledig plads til <entry>
og indsætter oplysningerne i hashtable og linktable
*>
begin
integer
_ ix,
_ lastix;
if hkey = 0 then
hkey:= compute_hashkey(name,owner);
if hashtable(hkey) extract 12 = nil then
begin
ix:= if hkey <= head.packentries then hkey else 1;
while linktable(ix) extract 12 <> free
do ix:= if ix < head.packentries then ix + 1 else 1;
hashtable(hkey):= false add ix;
linktable(ix) := false add nil;
end
else
begin
ix:= hashtable(hkey) extract 12;
while linktable(ix) extract 12 <> nil do
ix:= linktable(ix) extract 12;
lastix:= ix;
ix := if ix < head.packentries then ix + 1 else 1;
while linktable(ix) extract 12 <> free
do ix:= if ix < head.packentries then ix + 1 else 1;
linktable(lastix):= false add ix;
linktable(ix) := false add nil;
end;
find_record(cat,1,ix,head.entrylength,packcat_updated,packcat_leftblock);
cat.hashkey:= hkey;
cat.entryindex:= ix;
insert_tableentry:= ix;
<*+1*>
if test shift(-2) then
write(out,<:<10>insert tableentry, :>,name,<:, :>,owner,
_ <:, result =:>,ix);
<*-1*>
end insert_tableentry;
\f
procedure delete_tableentry(hashkey,entryno);
<*******************************************>
value hashkey,entryno ;
integer hashkey,entryno ;
<*
sletter entryno i linktable, hvis denne er den
eneste med indgang = hashkey, slettes indgangen
i hashtable
*>
begin
integer
_ ix;
if hashtable(hashkey) extract 12 = entryno then
begin
if linktable(entryno) extract 12 = nil
then hashtable(hashkey):= false add nil
else hashtable(hashkey):= linktable(entryno);
linktable(entryno):= false add free;
end
else
begin
ix:= hashtable(hashkey) extract 12;
while linktable(ix) extract 12 <> entryno
do ix:= linktable(ix) extract 12;
if linktable(entryno) extract 12 <> nil
then linktable(ix):= linktable(entryno)
else linktable(ix):= false add nil;
linktable(entryno):= false add free;
end;
<*+1*>
if test shift(-2) then
write(out,<:<10>delete tableentry, hashkey/entryno, :>,hashkey,entryno);
<*-1*>
end delete_tableentry;
\f
boolean procedure search_tableentry(cat,name,owner,bases,scope);
<**************************************************************>
value scope ;
zone cat ;
long array name,owner ;
integer array bases ;
integer scope ;
<* søger ud fra hashkey, en entry med det specificerede scope *>
begin
integer
_ ix,
_ hashkey;
boolean
_ search;
hashkey:= compute_hashkey(name,owner);
ix:= hashtable(hashkey) extract 12;
search:= true;
while search and ix <> nil do
begin
find_record(cat,1,ix,head.entrylength,packcat_updated,packcat_leftblock);
if name(1) = cat.entryname(1)
and name(2) = cat.entryname(2)
and owner(1) = cat.password(1)
and owner(2) = cat.password(2)
then search:= (entry_scope(cat.entrybase_adr,bases) <> scope);
if search then ix:= linktable(ix) extract 12;
end while search;
hashkey_computed := hashkey;
search_tableentry:= if ix <> nil then true else false;
<*+1*>
if test shift(-2) then
write(out,<:<10>search tableentry: :>,name,<:, :>,owner,
_ <:, scope =:>,scope,<:, result =:>,ix);
<*-1*>
end search_tableentry;
\f
boolean procedure lookup_tableentry(cat,name,owner,bases,scope);
<**************************************************************>
zone cat ;
long array name,owner ;
integer array bases ;
integer scope ;
<*
søger alle entries med <name> og <owner>, og returnerer scope
og entryno for den entry, der har det laveste scope
*>
begin
integer array
_ scopefound(temp:systemscope);
integer
_ entries_found,
_ ix,
_ lastix,
_ hashkey,
_ helpscope;
boolean
_ search;
for ix:=temp step 1 until systemscope
do scopefound(ix):= 0;
hashkey:= compute_hashkey(name,owner);
ix:= hashtable(hashkey) extract 12;
entries_found:=0;
search:= true;
while search and ix <> nil do
begin
find_record(cat,1,ix,head.entrylength,packcat_updated,packcat_leftblock);
if name(1) = cat.entryname(1)
and name(2) = cat.entryname(2)
and owner(1) = cat.password(1)
and owner(2) = cat.password(2)
then
begin
helpscope:= entry_scope(cat.entrybase_adr,bases);
if helpscope <> undefined then
begin
entries_found:= entries_found + 1;
scopefound(helpscope):= ix;
if helpscope = temp
or entries_found = 5
then search:= false;
end;
end;
lastix:= ix;
ix := linktable(ix) extract 12;
end while search;
if entries_found > 0 then
begin
for helpscope:=temp, helpscope
while helpscope <> undefined do
if scopefound(helpscope) > 0 then
begin
ix := scopefound(helpscope);
scope := helpscope ;
helpscope:= undefined ;
end
else helpscope:= helpscope + 1;
if ix <> lastix then
find_record(cat,1,ix,head.entrylength,packcat_updated,packcat_leftblock);
end
else ix:= nil;
lookup_tableentry:= if ix <> nil then true else false;
<*+1*>
if test shift(-2) then
write(out,<:<10>lookup tableentry: :>,name,<:, :>,owner,
_ <:, scope =:>,scope,<:, result =:>,ix);
<*-1*>
end lookup_tableentry;
\f
boolean procedure subcompare(text1,text2);
<****************************************>
long array text1,text2 ;
<*
tester om <text1> indledes med subtext <text2>
returværdien er da 'true' ellers 'false'
*>
begin
long
_ t1,
_ t2;
integer
_ index,
_ pos;
boolean
_ equal;
index:=1; equal:=true;
while equal and text2(index) extract 8 <> 'nul' do
begin
equal:=text1(index) = text2(index);
index:=index + 1;
end;
if equal then
begin
t1:=text1(index); t2:=text2(index);
pos:=-48;
for pos:=pos + 8
while equal
and t2 shift pos extract 8 <> 'nul'
do equal:=t1 shift pos extract 8 = t2 shift pos extract 8;
end;
subcompare:=equal;
end subcompare;
\f
integer procedure get_nextentryspec(name,nameadr);
<************************************************>
long array name ;
long array field nameadr ;
<*
henter næste bestilling af entries fra fillisten,
som er givet på formen
<name> eller
<name>.scope.<scopespec>
returværdier:
<name> og
<get_nextentryspec> = scope
*>
begin
long
_ scopeel;
integer
_ ix;
if optionlist.filelist_adr.nameadr(3) = '.' then
begin
scopeel:=optionlist.filelist_adr.nameadr(7);
get_nextentryspec:=
if scopeel = long <:temp:> then temp else
if scopeel = long <:login:> then login else
if scopeel = long <:user:> then user else
_ project ;
end
else
get_nextentryspec:= undefined;
for ix:= 1, 2 do
name(ix):= optionlist.filelist_adr.nameadr(ix);
nameadr:= nameadr + (if optionlist.filelist_adr.nameadr(3) = '.' then 36 else 12);
end get_nextentryspec;
\f
boolean procedure scan_packentry(packcat,bases,namelist,sublist,id,scope,found_namelist);
<***************************************************************************************>
zone packcat ;
integer array bases ;
long array namelist,sublist,id ;
integer scope ;
boolean array found_namelist ;
<*
søger en katalogindgang i packfilen som opfylder et af udvælgelseskriterierne
<navn>
<navn>.scope.<scopespec>
subtext.<præfix>
scope.<scopeklasse>
<scan_packentry> er true sålænge der findes flere mulige katalogindgange
anvendes kun til searchpack funktionen !!
*>
begin
own integer
_ entryno,
_ entryused;
long
_ scopeel;
integer
_ no,
_ helpscope;
boolean
_ entryfound;
long array field
_ name,
_ subname;
if entryno = 0 then
newposition(packcat,1,packcat_updated,packcat_leftblock);
entryfound:= false;
while entryno < head.packentries and -,entryfound do
begin
inrec6(packcat,head.entrylength);
entryno:= entryno + 1;
if packcat.key <> 0 then
begin
entryused:= entryused + 1;
<*
katalogindgangen skal være synlig for processen,
eller alle entries medtages uanset baserne,
og ownerid skal stemme overens, hvis ikke alle
katalogindgange medtages
*>
if (extend packcat.lowerbase <= bases(3)
and extend packcat.upperbase >= bases(4)
and (extend packcat.lowerbase >= bases(7)
and extend packcat.upperbase <= bases(8)
or system_packfile))
and (packcat.password(1) = id(1)
and packcat.password(2) = id(2)
or allowner)
or allpackfile
then
begin
helpscope:= undefined;
<*+1*>
if test shift(-1) then
begin
print_entry(out,packcat.entrybase_adr,bases,undefined,statlist);
write(out,<:, scan packentry:>);
end;
<*-1*>
<*
det undersøges nu om katalogindgangen
overhovedet er interessandt
*>
if no_of_files > 0 then
begin <* filliste er angivet *>
name:= 0;
for no:=1, no + 1 while no <= no_of_files and -,entryfound do
begin
if namelist.name(1) = packcat.entryname(1)
and namelist.name(2) = packcat.entryname(2) then
begin
if namelist.name(3) = '.' then
begin
scopeel:= namelist.name(7);
helpscope:=
if scopeel = long <:temp:> then temp else
if scopeel = long <:login:> then login else
if scopeel = long <:user:> then user else
_ project ;
end
else
helpscope:= undefined;
entryfound:=
if helpscope = undefined then true
else helpscope = entry_scope(packcat.entry_baseadr,bases);
if entryfound then
found_namelist(no):= true;
end name;
name:=name + (if namelist.name(3) = '.' then 36 else 12);
end no_of_files;
end filelist
;
<* der søges ved hjælp af scope eller subtext *>
if -,entryfound and scopeboo then
begin
helpscope:= entry_scope(packcat.entry_baseadr,bases);
if helpscope <> undefined then
entryfound:= scopelist(helpscope);
end;
if -,entryfound and no_of_subtext > 0 then
begin
subname:= 0;
for no:=1, no + 1 while no <= no_of_subtext and -,entryfound do
begin
entryfound:= subcompare(packcat.entryname,sublist.subname);
subname := subname + 12;
end;
end;
if -,entryfound then
begin
if no_of_files = 0 and -,scopeboo and no_of_subtext = 0
then entryfound:= true;
end;
end udvalgt entry;
end key <> 0;
end entryno;
if entryfound and helpscope = undefined then
helpscope:= entry_scope(packcat.entry_baseadr,bases);
scope:= helpscope; scan_packentry:= entryfound;
<*+1*>
if test shift(-2) and entryfound then
begin
print_entry(out,packcat.entrybase_adr,bases,scope,statlist);
write(out,<:, scan packentry:>);
end;
<*-1*>
end scan_packentry;
\f
boolean procedure next_packentry(packcat,bases,sublist,id,scope);
<***************************************************************>
zone packcat ;
integer array bases ;
long array sublist,id ;
integer scope ;
<*
søger en katalogindgang i packfilen, som opfylder et af kriterierne
subtext.<præfix>
scope.<scopeklasse>
<next_packentry> er true sålænge der findes flere mulige katalog-
indgange i packfilens katalog
*>
begin
own integer
_ entryno,
_ entryused;
integer
_ helpscope,
_ no;
boolean
_ entryfound;
long array field
_ subname;
if entryno = 0 then
newposition(packcat,1,packcat_updated,packcat_leftblock);
entryfound:= false;
while entryno < head.packentries and entryused < head.no_of_entries and -,entryfound do
begin
nextrecord(packcat,head.entrylength,packcat_updated,packcat_leftblock);
entryno:= entryno + 1;
if packcat.key <> 0 then
begin
entryused:= entryused + 1;
<*
katalogindgangen skal være synlig for processen,
og ownerid skal stemme overens med det angivne
*>
if extend packcat.lowerbase <= bases(3)
and extend packcat.upperbase >= bases(4)
and (extend packcat.lowerbase >= bases(7)
and extend packcat.upperbase <= bases(8)
or system_packfile)
and packcat.password(1) = id(1)
and packcat.password(2) = id(2)
then
begin
<*+1*>
if test shift(-1) then
begin
print_entry(out,packcat.entrybase_adr,bases,undefined,statlist);
write(out,<:, next packentry:>);
end;
<*-1*>
helpscope:= undefined;
if scopeboo then
begin
helpscope:= entry_scope(packcat.entrybase_adr,bases);
if helpscope <> undefined then
entryfound:= scopelist(helpscope);
end;
if -,entryfound and no_of_subtext > 0 then
begin
subname:= 0;
for no:=1, no + 1 while no <= no_of_subtext and -,entryfound do
begin
entryfound:= subcompare(packcat.entryname,sublist.subname);
subname := subname + 12;
end;
end;
end udvalgt entry;
end key <> 0;
end entryno;
if entryfound and helpscope = undefined then
helpscope:= entry_scope(packcat.entrybase_adr,bases);
scope:= helpscope; next_packentry:= entryfound;
<*+1*>
if test shift(-2) and entryfound then
begin
print_entry(out,packcat.entrybase_adr,bases,scope,statlist);
write(out,<:, next packentry:>);
end;
<*-1*>
end next_packentry;
\f
boolean procedure search_gap(gap,size);
<*************************************>
value size ;
zone gap ;
integer size ;
<*
søger et hul i hulkataloget, som er
større end eller lig med <size>
*>
begin
integer
_ no,
_ gapno,
_ min_gapadr,
_ min_gapsize;
boolean
_ gap_found;
newposition(gap,head.gapcat_adr,gapcat_updated,gapcat_leftblock);
no:= gapno :=
min_gapadr := 0 ;
min_gapsize:= maxint;
gap_found := false ;
while no < head.gapentries and gapno < head.no_of_gaps and -,gap_found do
begin
nextrecord(gap,4,gapcat_updated,gapcat_leftblock);
no:=no + 1;
if gap.first_emptysegm > 0 then
begin
gapno:=gapno + 1;
if gap.no_of_emptysegm = size
then gap_found:= true
else
if gap.no_of_emptysegm > size
and gap.no_of_emptysegm < min_gapsize then
begin
min_gapsize:= gap.no_of_emptysegm;
min_gapadr := no;
end;
end;
end søgning;
<* evt. skal en tidligere observeret indgang findes igen *>
if no >= min_gapadr and min_gapadr > 0 and -,gap_found then
begin
if no > min_gapadr then
find_record(gap,head.gapcat_adr,min_gapadr,4,gapcat_updated,gapcat_leftblock);
gap_found:= true;
end;
search_gap:= gap_found;
<*+1*>
if test shift(-2) then
begin
if gap_found then
write(out,<:<10>search gap, gap found: :>,<<ddddd>,gap.first_emptysegm,gap.no_of_emptysegm)
else
write(out,<:<10>search gap, gap not found:>);
end;
<*-1*>
end search_gap;
\f
boolean procedure delete_packentry(cat,gap);
<******************************************>
zone cat,gap ;
<*
sletter den aktuelle packfile_entry i cat
og indsætter de tomme segmenter i hulkataloget
*>
begin
integer
_ test_scope,
_ no,
_ gapno,
_ type;
boolean
_ expand;
integer field
_ i_field;
<*+1*> if test shift(-2) then
<*-1*> test_scope:= entry_scope(cat.entrybase_adr,intern_bases);
<* evt. kun entry *>
if cat.storeaddress = 0 then
begin
cat.key:=0;
head.no_of_entries :=head.no_of_entries - 1;
packcat_updated:= true;
end
else
<* evt. sidste område i packfile - denne kortes ned *>
if cat.storeaddress + cat.areasize = head.packfile_size then
begin
cat.key:=0;
head.packfile_size :=head.packfile_size - cat.areasize;
head.no_of_entries :=head.no_of_entries - 1;
head.no_of_segm :=head.no_of_segm - cat.areasize;
packcat_updated:= true;
end
else
<* det slettede område indsættes i hulkataloget *>
begin
<*
først undersøges om det er muligt at udvide et eksisterende hul
ellers må hullet indsættes i hulkataloget
*>
expand:=false;
no:=gapno:= 0;
newposition(gap,head.gapcat_adr,gapcat_updated,gapcat_leftblock);
while -,expand and no < head.gapentries and gapno < head.no_of_gaps do
begin
nextrecord(gap,4,gapcat_updated,gapcat_leftblock);
no:=no + 1;
if gap.first_emptysegm > 0 then
begin
gapno:=gapno + 1;
if cat.storeaddress = gap.first_emptysegm + gap.no_of_emptysegm then
begin
expand:=true;
type:=1;
end
else
if cat.storeaddress + cat.areasize = gap.first_emptysegm then
begin
expand:=true;
type:=2;
end;
end gapentry > 0;
end search;
<* evt. søges en fri gap_entry *>
if -,expand and head.gapentries - head.no_of_gaps > 0 then
begin
newposition(gap,head.gapcat_adr,gapcat_updated,gapcat_leftblock);
repeat
nextrecord(gap,4,gapcat_updated,gapcat_leftblock);
until gap.first_emptysegm = 0;
end;
<* entry slettes *>
if expand or head.gapentries - head.no_of_gaps > 0 then
begin
cat.key:=0;
head.no_of_entries :=head.no_of_entries - 1;
head.no_of_segm :=head.no_of_segm - cat.areasize;
packcat_updated:= true;
end;
if expand then
begin
if type = 1 then
gap.no_of_emptysegm:=gap.no_of_emptysegm + cat.areasize
else
begin
gap.first_emptysegm:=cat.storeaddress;
gap.no_of_emptysegm:=gap.no_of_emptysegm + cat.areasize;
end;
head.no_of_gapsegm := head.no_of_gapsegm + cat.areasize;
gapcat_updated:= true;
end expand
else
if head.gapentries - head.no_of_gaps > 0 then
begin
gap.first_emptysegm :=cat.storeaddress;
gap.no_of_emptysegm :=cat.areasize ;
head.no_of_gaps := head.no_of_gaps + 1;
head.no_of_gapsegm := head.no_of_gapsegm + cat.areasize;
gapcat_updated:= true;
end
else
begin
print_entry(ud,cat.entry_baseadr,intern_bases,undefined,ownerlist);
write(ud,"sp",5,<:*** gapcatalog is full, not deleted:>);
end;
end indsættelse i hulkatalog og sletning;
delete_packentry:= if cat.key = 0 then true else false;
<*+1*>
if test shift(-2) then
begin
print_entry(out,cat.entrybase_adr,intern_bases,test_scope,statlist);
write(out,<:, delete :>,if cat.key = 0 then <:ok:> else <:not ok:>);
end;
<*-1*>
<* resten af entry slettes *>
if cat.key = 0 then
begin
if hashing_used then delete_tableentry(cat.hashkey,cat.entryindex);
for i_field:= head.entrylength step -2 until 4
do cat.i_field:= 0;
swop_cat(cat,packcat_updated,gap,gapcat_updated);
end;
end delete_packentry;
\f
boolean procedure insert_packentry(cat,gap,entry,bases,catalog_scope,scope,hkey);
<******************************************************************************>
value catalog_scope,scope,hkey ;
zone cat,gap ;
integer array entry,bases ;
integer catalog_scope,scope,hkey ;
<*
katalogindgangen og det evt. tilhørende dataområde forsøges
indsat i packfilens katalog og fortrinsvis i tomme huller
insert_packentry=true, hvis indsættelsen lykkedes
*>
begin
integer
_ position,
_ return;
boolean
_ gap_found,
_ entry_found,
_ packfile_extended,
_ skip;
<* alle temp og login entries lægges på min. userbase *>
if scope = temp or scope = login then
begin
if entry.lowerbase > bases(5) then
begin
entry.upperbase:=entry.upperbase - (entry.lowerbase - bases(5));
entry.lowerbase:=bases(5);
end;
end;
<* hvis der er tale om et område, søges et hul i hulkataloget *>
if entry.areasize > 0 and head.no_of_gaps > 0 then
gap_found:= search_gap(gap,entry.areasize)
else
gap_found:= false;
<* der søges en plads til katalogindgangen *>
if head.packentries - head.no_of_entries > 0 then
begin
entry_found:= true;
insert_tableentry(cat,entry.entryname,ownerid,hkey);
end
else entry_found:= false;
skip:= false;
if entry_found then
begin
<* evt. skal packfilen udvides *>
packfile_extended:= false;
if entry.areasize > 0 and -,gap_found then
begin
integer array
_ tail(1:10);
return:=monitor(42,head,0,tail);
if return <> 0 then
monitor_error(42,head,return,true);
tail(1):=head.packfile_size + entry.areasize;
return :=monitor(44,head,0,tail);
if return = 0 then
begin
position:=head.packfile_size;
packfile_extended:= true;
end
else
begin
skip:= true;
print_entry(ud,entry,bases,scope,normlist);
write(ud,"sp",5,<:*** packfile cannot be extended, area not inserted:>);
if return <> 6 then
monitor_error(44,head,return,true);
end;
end
else
if gap_found then
position:= gap.first_emptysegm;
<* området overføres til packfilen *>
if entry.areasize > 0 and -,skip then
begin
skip:= -,movearea(packfile,position,undefined,
_ entry.entryname,0,catalog_scope,
_ max_bufsegm,entry.areasize);
if skip then
begin
print_entry(ud,entry,bases,scope,normlist);
write(ud,"sp",5,<:*** entry in use, not inserted:>);
end;
end;
<* det evt.fundne hul fjernes fra kataloget eller reduceres *>
if gap_found and -,skip then
begin
if gap.no_of_emptysegm = entry.areasize then
begin
head.no_of_gaps :=head.no_of_gaps - 1;
head.no_of_gapsegm :=head.no_of_gapsegm - entry.areasize;
gap.first_emptysegm :=gap.no_of_emptysegm := 0;
end
else
begin
head.no_of_gapsegm :=head.no_of_gapsegm - entry.areasize;
gap.first_emptysegm :=gap.first_emptysegm + entry.areasize;
gap.no_of_emptysegm :=gap.no_of_emptysegm - entry.areasize;
end;
gapcat_updated:= true;
end;
<* katalog indgangen indsættes i packfilens katalog *>
if -,skip then
begin
tofrom(cat.entry_baseadr,entry,34);
if entry.areasize > 0 then
cat.storeaddress:=position;
cat.password(1) := ownerid(1);
cat.password(2) := ownerid(2);
cat.packdate := date;
cat.last_accessdate
_ := date;
cat.no_of_read := 0;
cat.no_of_point := 0;
if entry.areasize < 0 then
begin
if newkit(1) <> empty then
tofrom(cat.auxdocname,newkit,8)
else
lookup_auxdoc(cat.auxdocname,if entry.key shift(-12) > 0 then
_ entry.key shift(-12) - 2048 else 0);
end;
head.no_of_entries := head.no_of_entries + 1;
if packfile_extended then
head.packfile_size := head.packfile_size + entry.areasize;
if entry.areasize > 0 then
head.no_of_segm := head.no_of_segm + entry.areasize;
packcat_updated:= true;
swop_cat(cat,packcat_updated,gap,gapcat_updated);
end if -,skip;
end entry_found
else
begin
skip:= true;
print_entry(ud,entry,bases,scope,normlist);
write(ud,"sp",5,<:*** no free entries, not inserted:>);
end;
insert_packentry:= -,skip;
<*+1*>
if test shift(-2) then
begin
print_entry(out,entry,bases,scope,normlist);
write(out,<:, insert :>,if -,skip then <:ok:> else <:not ok:>);
end;
<*-1*>
end insert_packentry;
\f
procedure reorganize_gapcat(gap);
<*******************************>
zone gap ;
<*
afkorter packfilen såfremt denne
afsluttes med ubrugte huller
*>
begin
integer array
_ gap_tab(1:head.no_of_gaps,1:3);
real
_ base,
_ c,
_ r0,
_ r;
integer
_ last_found,
_ gapno,
_ gapused;
<*+1*>
if test shift(-5) then
begin
systime(1,0,base);
c:=systime(1,base,r0);
end;
<*-1*>
gapused:= 0;
newposition(gap,head.gapcat_adr,gapcat_updated,gapcat_leftblock);
for gapno:=1 step 1 until head.gapentries do
begin
nextrecord(gap,4,gapcat_updated,gapcat_leftblock);
if gap.first_emptysegm > 0 then
begin
gapused:= gapused + 1;
if gapused <= head.no_of_gaps then
begin
gap_tab(gapused,1):= gap.first_emptysegm;
gap_tab(gapused,2):= gapno ;
gap_tab(gapused,3):= gap.no_of_emptysegm;
end
else
break(<:*** used entries in gapcat exceeds no of gapentries:>,gapused,true);
end;
end;
<* tabellen sorteres i stigende orden efter første segment nr. *>
quicksort(gap_tab,gapused,3,1);
<* nu løbes tabellen igennem og hulkataloget reorganiseres evt. *>
last_found:= 0;
while gapused > 0 do
begin
<*+1*>
if test shift(-2) then
write(out,<:<10>reorganize gapcat, entryused =:>,<<ddddddd>,gapused,
_ <:, first emptysegm =:>,gap_tab(gapused,1),
_ <:, no of emptysegm =:>,gap_tab(gapused,3));
<*-1*>
<* det undersøges om packfilen kan afkortes *>
if gap_tab(gapused,1) + gap_tab(gapused,3) >= head.packfile_size then
begin
find_record(gap,head.gapcat_adr,gap_tab(gapused,2),4,gapcat_updated,gapcat_leftblock);
<*+1*>
if test shift(-2) then
write(out,<:<10>reorganize gapcat, packfile was cut down by segm =:>,head.packfile_size - gap.first_emptysegm);
<*-1*>
head.no_of_gaps := head.no_of_gaps - 1;
head.no_of_gapsegm := head.no_of_gapsegm - gap.no_of_emptysegm;
head.packfile_size := gap.first_emptysegm ;
gap.first_emptysegm:=
gap.no_of_emptysegm:= 0;
gapcat_updated := true;
end
else
<* det undersøges om nogle huller kan sammenlægges *>
if gapused > 1 then
begin
if gap_tab(gapused - 1, 1) + gap_tab(gapused - 1, 3) = gap_tab(gapused,1) then
begin
if last_found <> gap_tab(gapused,2) then
find_record(gap,head.gapcat_adr,gap_tab(gap_used,2),4,gapcat_updated,gapcat_leftblock);
head.no_of_gaps := head.no_of_gaps - 1;
gap.first_emptysegm:=
gap.no_of_emptysegm:= 0;
gapcat_updated := true;
find_record(gap,head.gapcat_adr,gap_tab(gap_used - 1, 2),4,gapcat_updated,gapcat_leftblock);
last_found:= gap_tab(gapused - 1, 2);
gap.no_of_emptysegm:= gap_tab(gapused - 1, 3):= gap.no_of_emptysegm + gap_tab(gapused,3);
gapcat_updated := true;
<*+1*>
if test shift(-2) then
write(out,<:<10>reorganise gapcat, two gaps reduced to one, first segm =:>,
_ <<ddddd>,gap_tab(gapused-1,1),<:, no of segm =:>,gap_tab(gapused-1,3));
<*-1*>
end;
end;
gapused:= gapused - 1;
end;
<*+1*>
if test shift(-5) then
begin
c:=systime(1,base,r) - c;
r:=r - r0;
write(out,<:<10>reorganisering af gapcat, cputid/realtid :>,<<ddd.dddd>,c,r);
end;
<*-1*>
end reorganize_gapcat;
\f
integer procedure compute_last_date(act_date,days);
<*************************************************>
value act_date,days ;
integer act_date,days ;
<*
proceduren beregner datoen på den dag, som ligger
<days> antal dage før <act_date>
*>
begin
integer
_ dd,
_ mm,
_ yy,
_ counter;
dd:= act_date mod 100;
mm:= act_date // 100 mod 100;
yy:= act_date // 10000;
for counter:= 1 step 1 until days do
begin
dd:= dd - 1;
if dd < 1 then
begin
mm:= mm - 1;
if mm < 1 then
begin
mm:= 12;
yy:= yy - 1;
end if mm < 1;
dd:= case mm of (31,if yy mod 4 = 0 then 29 else 28,31,30,31,30,31,31,30,31,30,31);
end if dd < 1;
end no of days;
compute_last_date:= yy * 10000 + mm * 100 + dd;
<*+1*> if test shift(-2) then
<*-1*> write(out,<:<10>compute last date =:>,<< dd dd dd>,yy*10000+mm*100+dd);
end compute_last_date;
\f
procedure purge(cat,gap,lastdate,type,list);
<******************************************>
value lastdate,type,list ;
zone cat,gap ;
integer lastdate,type ;
boolean list ;
<*
sletter entries i packfilen, som er ældre end
<lastdate> afhængig af slettetypen <type>
type:
1: entrydate
2: packdate
3: lastaccessdate
*>
begin
integer array
_ saveentry(1:head.entrylength//2);
integer
_ total_entryused,
_ entryno,
_ entryused,
_ test_date;
newposition(cat,1,packcat_updated,packcat_leftblock);
total_entryused := head.no_of_entries; <* gemmes da entries slettes undervejs *>
entryno:= entryused:= 0;
while entryno < head.packentries and entryused < total_entryused do
begin
nextrecord(cat,head.entrylength,packcat_updated,packcat_leftblock);
entryno:= entryno + 1;
if cat.key <> 0 then
begin
entryused:= entryused + 1;
test_date:=
case type of (
if cat.entrytail(1) <> 0 and cat.entrytail(4) <> 4 and cat.entrytail(4) < 32
then systime(6,cat.entrytail(1),0.0) else lastdate,
cat.packdate,
cat.last_accessdate);
<*+1*>
if test shift(-2) then
write(out,<:<10>purge, testdate =:>,<< dd dd dd>,test_date,<:, lastdate =:>,lastdate,<:, type =:>,<<dd>,type);
<*-1*>
if test_date < lastdate then
begin
if list then
tofrom(saveentry,cat.entrybase_adr,head.entrylength);
if delete_packentry(cat,gap) and list then
print_entry(ud,saveentry,intern_bases,undefined,ownerlist);
end;
end cat.key <> 0;
end entries;
end purge;
\f
procedure pack;
<*************>
<*
indsætter de ønskede katalogindgange
og evt. tilhørende områder i packfilen
*>
begin
boolean procedure reserved(name,scope);
<*************************************>
long array name ;
integer scope ;
<*
undersøger om det er tilladt at pakke
en angiven entry med specificeret scope
*>
begin
reserved:=
if name(1) = long <:c:> and scope = temp
or name(1) = long <:v:> and scope = temp
or name(1) = long <:primo:> add 'u' and name(2) = long <:t:> and scope = login
or name(1) = long <:pack:>
or name(1) = packfile(1) and name(2) = packfile(2)
or name(1) = outfile(1) and name(2) = outfile(2)
then true else false;
end reserved;
procedure set_newscope(entry);
<****************************>
integer array entry ;
begin
integer
_ ix;
entry.key:= entry.key shift(-3) shift 3
_ add (case newscope + 1 of (0,2,3,3));
ix:= case newscope + 1 of (3,3,5,7);
entry.lowerbase:= process_bases(ix);
entry.upperbase:= process_bases(ix + 1);
end;
procedure remove_entry(name,scope);
<*********************************>
value scope ;
long array name ;
integer scope ;
<*
sletter en entry, som er indsat i packfilen
*>
begin
zone
_ rem(1,1,stderror);
integer array
_ ia(1:2);
integer
_ ix,
_ return;
if scope > login then
begin
ix := case scope + 1 of (3,3,5,7);
ia(1):= process_bases(ix);
ia(2):= process_bases(ix + 1);
return:= monitor(72)set_cat_base:(myself,0,ia);
if return <> 0 then monitor_error(72,myself,return,true);
end;
open(rem,0,name,0);
return:= monitor(48)remove_entry:(rem,0,ia);
if return <> 0 then
begin
monitor_error(48,rem,return,false);
write(ud,<:<10>*** entry could not be removed after pack:>);
end;
close(rem,true);
if scope > login then
begin
return:= monitor(72)set_cat_base:(myself,0,process_bases);
if return <> 0 then monitor_error(72,myself,return,true);
end;
end remove_entry;
long array
_ name(1:2);
integer array
_ save_entry(1:head.entrylength//2),
_ catalogentry(1:17);
integer
_ nextname_adr,
_ fileno,
_ look_return;
boolean
_ ok;
integer array field
_ last_part;
last_part:= 34;
print_heading(ud,normlist);
if no_of_files > 0 then
begin
nextname_adr:= 0;
for fileno:=1 step 1 until no_of_files do
begin
scope:= get_nextentryspec(name,nextname_adr);
<*
katalogindgangen søges, og såfremt den findes
pakkes den med det evt. tilhørende område
*>
look_return:=lookup_entry(catalogentry,process_bases,name,scope);
if look_return = -1
or reserved(name,scope) then
lookup_error(ud,name,scope,false,if look_return = -1 then 1 else 2)
else
begin
tofrom(save_entry,catalogentry,34);
if newscope <> undefined then set_newscope(catalogentry);
if newkit(1) <> empty and catalogentry.areasize >= 0 then
tofrom(catalogentry.documentname,newkit,8);
ok:=
if search_tableentry(packcat,name,ownerid,intern_bases,
_ if newscope = undefined then scope else newscope)
then delete_packentry(packcat,gapcat)
else true;
if ok then
begin
if insert_packentry(packcat,gapcat,catalogentry,intern_bases,scope,
_ if newscope = undefined then scope else newscope,hashkey_computed) then
begin
tofrom(saveentry.last_part,packcat.last_part,head.entrylength-34);
print_entry(ud,save_entry,process_bases,scope,normlist);
if remove then remove_entry(name,scope);
end;
end;
end pack of entry;
end denne fil;
end no_of_files
;
<* der søges direkte i main-catalog *>
if scopeboo or no_of_subtext > 0 then
begin
zone
_ look(128*2,2,stderror);
open(look,4,<:catalog:>,0);
while search_catalogentry(look,catalogentry,process_bases,scope) do
if -,reserved(catalogentry.entryname,scope) then
begin
tofrom(save_entry,catalogentry,34);
if newscope <> undefined then set_newscope(catalogentry);
if newkit(1) <> empty and catalogentry.areasize >= 0 then
tofrom(catalogentry.documentname,newkit,8);
ok:=
if search_tableentry(packcat,catalogentry.entryname,ownerid,intern_bases,
_ if newscope = undefined then scope else newscope)
then delete_packentry(packcat,gapcat)
else true;
if ok then
begin
if insert_packentry(packcat,gapcat,catalogentry,intern_bases,scope,
_ if newscope = undefined then scope else newscope,hashkey_computed) then
begin
tofrom(saveentry.last_part,packcat.last_part,head.entrylength-34);
print_entry(ud,save_entry,process_bases,scope,normlist);
if remove then remove_entry(catalogentry.entryname,scope);
end;
end;
end catalog;
close(look,true);
end;
end pack;
\f
procedure unpack;
<***************>
<*
opretter de relevante entries og områder
på baggrundslager ud fra oplysninger i
packfilens katalog med scope = login
hvis newscope ikke er angivet.
hvis changekit er angivet oprettes på
det navngivne baggrundslager dokument
*>
begin
long array
_ name(1:2);
integer array
_ saveentry(1:head.entrylength//2);
integer
_ create_result,
_ fileno,
_ nextname_adr;
boolean
_ ok,
_ found;
procedure create;
<***************>
begin
tofrom(saveentry,packcat.entrybase_adr,head.entrylength);
create_result:= create_entry(saveentry,newkit,process_bases,newscope);
if create_result >= 0 then
begin
if saveentry.areasize > 0 then
ok:= movearea(saveentry.entryname,0,newscope,
_ packfile,saveentry.storeaddress,undefined,
_ max_bufsegm,saveentry.areasize)
else ok:= true;
if -,ok then
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
write(ud,"sp",5,<:*** area move not complete:>);
end
else
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
if create_result = 1 then
write(ud,"sp",5,<:*** temp, no login resources:>);
<* statistikkerne opdateres *>
if -,system_packfile then
begin
packcat.no_of_read:= packcat.no_of_read + 1;
packcat.lastaccess_date:= date;
packcat_updated:= true;
end;
end;
end
else
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
write(ud,"sp",5,case abs create_result of (
_ <:*** no resources:>,<:*** name conflict:>));
end;
end create;
print_heading(ud,normlist);
nextname_adr:= 0;
for fileno:=1 step 1 until no_of_files do
begin
scope:= get_nextentryspec(name,nextname_adr);
found:=
if scope = undefined then
lookup_tableentry(packcat,name,ownerid,intern_bases,scope)
else
search_tableentry(packcat,name,ownerid,intern_bases,scope);
if found then create
else lookup_error(ud,name,scope,false,1);
end;
if scopeboo or no_of_subtext > 0 then
begin
while next_packentry(packcat,intern_bases,optionlist.subtext_adr,ownerid,scope)
do create;
end;
end unpack;
\f
procedure searchpack;
<*******************>
<*
lister indholdet af packfile
*>
begin
long array
_ helpname,
_ name(1:2);
integer array
_ dummy(1:1);
boolean array
_ namefound(1:(if no_of_files > 0 then no_of_files else 1));
integer
_ namebase,
_ records,
_ no;
<* all.owner er default for alle filer undtagen "publicpack" *>
if (packfile(1) <> long <:publi:> add 'c'
or packfile(2) <> long <:pack:>)
and ownerid(1) = long <::>
then allowner:= true;
for no:=1 step 1 until no_of_files do
namefound(no):= false;
write(ud,<< dddddd>,
_ "nl",2,<:size =:>,head.packfile_size,
_ "sp",5,<:creation date =:>,head.creation_date,
_ "nl",1,<:max. entries =:>,head.packentries,
_ "sp",5,<:max. gaps =:>,head.gapentries,
_ "nl",1,<:used entries =:>,head.no_of_entries,
_ "sp",5,<:segments =:>,head.no_of_segm,
_ "nl",1,<:gaps =:>,head.no_of_gaps,
_ "sp",5,<:gapsegments =:>,head.no_of_gapsegm);
if head.retention_days < maxint then
write(ud,<< dddddd>,
_ "nl",2,<:retention days =:>,head.retention_days);
write(ud,"nl",2);
case listtype of
begin
print_heading(ud,ownerlist);
print_heading(ud,statlist);
;
end;
begin
zone helpz(128,1,stderror);
helpname(1):= helpname(2):= empty;
connect(helpz,helpname,head.gapcat_adr - 1);
records:= 0;
while scan_packentry(packcat,intern_bases,optionlist.filelist_adr,
_ optionlist.subtext_adr,ownerid,scope,namefound)
do
begin
records:= records + 1;
outrec6(helpz,head.entrylength);
tofrom (helpz,packcat,head.entrylength);
helpz.entryindex:= scope;
end;
close(helpz,true);
end;
if records > 0 then
begin
if records > 1 then
begin
no:= 1;
discsort(string helpname(increase(no)),head.entrylength,records,1,0,
<* key 1 *> password + 4,
<* key 2 *> password + 8,
<* key 3 *> entryname + 4,
<* key 4 *> entryname + 8,
<* key 5 *> entryindex);
end records > 1;
begin
zone helpz(128,1,stderror);
connect(helpz,helpname,0);
for no:= 1 step 1 until records do
begin
inrec6(helpz,head.entrylength);
scope:=helpz.entryindex;
if listtype < 3
then print_entry(ud,helpz.entrybase_adr,intern_bases,scope,
_ case listtype of(ownerlist,statlist))
else print_head_and_tail(ud,helpz.entry_baseadr,intern_bases,scope);
end;
monitor(48)remove_entry:(helpz,0,dummy);
close(helpz,true);
end;
end records > 0;
<* test af hvorvidt specificerede navne blev fundet *>
if no_of_files > 0 then
begin
namebase:= 0;
for no:=1 step 1 until no_of_files do
begin
scope:= get_nextentryspec(name,namebase);
if -,namefound(no) then
lookup_error(ud,name,scope,false,1);
end;
end;
end searchpack;
\f
procedure clearpack;
<******************>
<*
sletter de specificerede
packentries og evt.
tilhørende områder
*>
begin
long array
_ name(1:2);
integer array
_ saveentry(1:head.entrylength//2);
integer
_ nextname_adr,
_ fileno;
boolean
_ entryfound;
print_heading(ud,normlist);
nextname_adr:= 0;
for fileno:=1 step 1 until no_of_files do
begin
scope:= get_nextentryspec(name,nextname_adr);
entryfound:=
if scope = undefined then
lookup_tableentry(packcat,name,ownerid,intern_bases,scope)
else
search_tableentry(packcat,name,ownerid,intern_bases,scope);
if entryfound then
begin
tofrom(saveentry,packcat.entry_baseadr,head.entrylength);
if delete_packentry(packcat,gapcat) then
print_entry(ud,saveentry,intern_bases,scope,normlist);
end
else
lookup_error(ud,name,scope,false,1);
end no_of_files;
end clearpack;
\f
procedure repack;
<***************>
begin
procedure set_securityfile(entry);
<********************************>
integer array entry ;
begin
integer
_ i,
_ return;
if secu_tail(1) = -1 then
begin
integer array
_ ia(1:10),
_ kit(1:4);
long array field
_ device;
device:= 2;
for i:= 1 step 1 until 10 do
secu_tail(i):= 0;
if -,security then
begin
secu_tail.device(1):= extend 1 shift 24; <* disckit is prefered *>
secu_tail.device(2):= long <::> ;
end
else
if -,get_permkit_name(secu_tail.device) then
break(<:*** security requires permanent resources to create file "repacksafe":>,0,true);
open(secu,4,securityfile,0);
secu_tail(1):= 1;
return:= monitor(42)lookup_entry:(secu,0,ia);
if return = 0 then
begin
if ia(1) = 0 then
begin
return:= monitor(48)remove_entry:(secu,0,ia);
if return <> 0 then
monitor_error(48,secu,return,false);
end;
if ia(1) <> 0 or return <> 0 then
break(<:*** security file "repacksafe" exist from a previous run !!:>,0,true);
end;
return:= monitor(40)create_entry:(secu,0,secu_tail);
if return <> 0 then
monitor_error(40,secu,return,true);
if security then
begin
tofrom(kit,secu_tail.device,8);
if -,change_scope(secu,kit,process_bases,user) then
begin
return:= monitor(48)remove_entry:(secu,0,secu_tail);
if return <> 0 then
begin
write(out,<:<10>*** area repacksafe not removed:>);
monitor_error(48,secu,return,false);
end;
break(<:*** "repacksafe" cannot be made permanent:>,0,true);
end;
end;
end;
secu_tail(1):= entry.areasize;
for i:=6 step 1 until 10 do
secu_tail(i):= entry.entrytail(i-5);
return:= monitor(44)change_entry:(secu,0,secu_tail);
if return <> 0 then
begin
i:= monitor(48)remove_entry:(secu,0,secu_tail);
if i <> 0 then
begin
write(out,<:<10>*** area "repacksafe" not removed:>);
monitor_error(48,secu,i,false);
end;
if return = 6 then
break(<:*** no resources to set "repacksafe", needed segments =:>,secu_tail(1),true)
else
monitor_error(44,secu,return,true);
end;
end set_securityfile;
procedure cut_securityfile;
<*************************>
<*
sætter størrelsen af securityfilen
"repacksafe" til 0 segmenter
*>
begin
integer i;
for i:= 1, 6 step 1 until 10 do
secu_tail(i):= 0;
i:= monitor(44)change_entry:(secu,0,secu_tail);
if i <> 0 then
monitor_error(44,secu,i,true);
end cut_securityfile;
zone
_ secu(128,1,stderror);
long array
_ securityfile(1:2);
integer array
_ entry_tab(1:(if head.no_of_entries > 0 then head.no_of_entries else 1),1:3),
_ secu_tail(1:10);
integer
_ i,
_ segm_pointer,
_ old_address,
_ entryno,
_ entryused;
boolean
_ packcat_extension;
packcat_extension:= dim_packentries > head.packentries;
print_heading(ud,ownerlist);
<* gennemløb af packcat *>
entryused:= 0;
newposition(packcat,1,packcat_updated,packcat_leftblock);
for entryno:=1 step 1 until head.packentries do
begin
nextrecord(packcat,head.entrylength,packcat_updated,packcat_leftblock);
if packcat.key <> 0 then
begin
entryused:= entryused + 1;
if entryused <= head.no_of_entries then
begin
entry_tab(entryused,1):= packcat.storeaddress;
entry_tab(entryused,2):= entryno;
entry_tab(entryused,3):= packcat.areasize ;
end
else
break(<:*** used entries in packcat exceeds no of entries:>,entryused,true);
end;
end;
<* sortering af tabellen *>
quicksort(entry_tab,entryused,3,1);
<* klargøring af securityområde *>
securityfile(1):= long <:repac:> add 'k';
securityfile(2):= long <:safe:> ;
secu_tail(1) := -1; <* bevirker initialisering af området *>
<* evt. ændring af katalogernes størrelse i packfilen *>
if dim_packentries > 0 or dim_gapentries > 0 then
begin
boolean
_ extension_ok,
_ gap_found;
integer
_ return,
_ newsize,
_ newgapcat_adr,
_ new_first_areasegm,
_ totalused;
if dim_packentries < head.packentries
then dim_packentries:= head.packentries;
if dim_gapentries = 0
then dim_gapentries := head.gapentries;
newsize:=
1 +
(dim_packentries - 1)//(512//head.entrylength) + 1 +
(dim_gapentries - 1)//(512//4) + 1;
newgapcat_adr:=
1 + (dim_packentries - 1)//(512//head.entrylength) + 1;
new_first_areasegm:=
newgapcat_adr + (dim_gapentries - 1)//(512//4) + 1;
extension_ok:= true;
if newsize > head.first_areasegm then
begin
totalused:= entryused;
entryused:= 0 ;
<* entries uden areal overspringes *>
repeat entryused:= entryused + 1
until entryused = head.no_of_entries
or entry_tab(entryused,1) <> 0;
segmpointer:= head.first_areasegm;
<* den egentlige flytning af områder påbegyndes *>
while segm_pointer < newsize
and entryused <= head.no_of_entries
and extension_ok
do
begin
<* området må evt. flyttes *>
if entry_tab(entryused,1) < newsize then
begin
find_record(packcat,1,entry_tab(entryused,2),head.entrylength,
_ packcat_updated,packcat_leftblock);
gap_found:=
if head.no_of_gaps > 0 then
search_gap(gapcat,entry_tab(entryused,3))
else false;
if gap_found then
begin
if movearea(packfile,gapcat.first_emptysegm,undefined,
_ packfile,packcat.storeaddress,undefined,
_ max_bufsegm,packcat.areasize)
then
begin
entry_tab(entryused,1):=
packcat.storeaddress := gapcat.first_emptysegm;
packcat_updated := true;
if packcat.areasize = gapcat.no_of_emptysegm then
begin
gapcat.first_emptysegm:=
gapcat.no_of_emptysegm:= 0;
head.no_of_gaps := head.no_of_gaps - 1;
end
else
<* hullet reduceres *>
gapcat.first_emptysegm:= gapcat.first_emptysegm + packcat.areasize;
gapcat_updated := true;
end if movearea;
end if gapfound
else
<* packfilen må udvides *>
begin
packtail(1):= packtail(1) + packcat.areasize;
return:= monitor(44)change_entry:(head,0,packtail);
if return = 0 then
begin
if movearea(packfile,head.packfile_size,undefined,
_ packfile,packcat.store_address,undefined,
_ max_bufsegm,packcat.areasize)
then
begin
entry_tab(entryused,1):=
packcat.storeaddress := head.packfile_size;
head.packfile_size := head.packfile_size + packcat.areasize;
packcat_updated := true;
end
else
extension_ok:= false;
end
else
begin
extension_ok:= false;
write(out,"nl",2,<:*** no resources, packfile cannot be extended !:>);
if return <> 6 then
monitor_error(44,head,return,true);
end;
end udvidelse;
end flytning af område
else
segm_pointer:= entry_tab(entryused,1);
entryused:= entryused + 1;
end extensionløkke;
<* entrytabellen må sorteres igen *>
quicksort(entrytab,totalused,3,1);
end newsize > head.first_areasegm;
if extension_ok then
begin
<* det markeres at entry-kataloget er under udvidelse *>
if packcat_extension then
begin
newposition(packcat,0,packcat_updated,packcat_leftblock);
head.extend_mark:= 1;
setposition(head,0,0);
swoprec6(head,512);
end;
<* de nye katalogsegmenter nulstilles *>
if new_first_areasegm > head.first_areasegm then
begin
gapcat_updated:= false;
setposition(gapcat,0,head.gapcat_adr);
outrec6(gapcat,512);
for i:= 1 step 1 until 128 do
gapcat(i):= real <::>;
for i:= head.gapcat_adr + 1 step 1 until new_first_areasegm - 1 do
outrec6(gapcat,512);
setposition(gapcat,0,0);
head.no_of_gaps:= head.no_of_gapsegm:= 0;
set_packtail(head,packtail,2);
end;
head.gapcat_adr := newgapcat_adr;
head.first_areasegm:= new_first_areasegm;
head.gap_entries := dim_gapentries ;
<* der beregnes ny nøgler til hashtabellen *>
if packcat_extension then
begin
head.pack_entries := dim_packentries;
head.hashtable_size:= compute_hashtable_size(head.packentries);
newposition(packcat,1,packcat_updated,packcat_leftblock);
for entryno:=1 step 1 until head.packentries do
begin
nextrecord(packcat,head.entrylength,packcat_updated,packcat_leftblock);
if packcat.key <> 0 then
begin
packcat.hashkey:= compute_hashkey(packcat.entryname,packcat.password);
packcat_updated:= true;
end;
end;
newposition(packcat,0,packcat_updated,packcat_leftblock);
head.extend_mark:= 0;
setposition(head,0,0);
swoprec6(head,512);
end nye hashnøgler;
end;
end udvidelse af kataloger;
<* for at undgå fejl nulstilles hulkataloget indledningsvis *>
if -,packcat_extension then
begin
gapcat_updated:= false;
setposition(gapcat,0,head.gapcat_adr);
outrec6(gapcat,512);
for i:= 1 step 1 until 128 do
gapcat(i):= real <::>;
for i:= head.gapcat_adr + 1 step 1 until head.first_areasegm - 1 do
outrec6(gapcat,512);
setposition(gapcat,0,0);
head.no_of_gaps := 0;
head.no_of_gapsegm:= 0;
set_packtail(head,packtail,2);
end nulstilling;
<* nu er hulkataloget ude af spillet *>
entryused:= 0;
<* entries uden areal overspringes *>
repeat entryused:= entryused + 1;
until entryused = head.no_of_entries
or entry_tab(entryused,1) <> 0;
<* nu kan repack begynde *>
segm_pointer:= head.first_areasegm;
while entryused <= head.no_of_entries do
begin
<*+1*>
if test shift(-2) then
write(out,<:<10>repack, entryuse, storeadr, recordno, size, segmpoint<10>:>,
_ "sp",6,<< dddddd>,entryused,entry_tab(entryused,1),entry_tab(entryused,2),
_ entry_tab(entryused,3),segmpointer);
<*-1*>
if segm_pointer < entry_tab(entryused,1) then
begin
find_record(packcat,1,entry_tab(entryused,2),head.entrylength,
_ packcat_updated,packcat_leftblock);
<* direkte flytning *>
if packcat.areasize <= packcat.storeaddress - segm_pointer then
begin
movearea(packfile,segm_pointer,undefined,
_ packfile,packcat.storeaddress,undefined,
_ maxbufsegm,packcat.areasize);
print_entry(ud,packcat.entrybase_adr,intern_bases,undefined,ownerlist);
end
else
<* indirekte flytning *>
begin
set_securityfile(packcat.entry_baseadr);
movearea(security_file,0,undefined,
_ packfile,packcat.storeaddress,undefined,
_ maxbufsegm,packcat.areasize);
print_entry(ud,packcat.entrybase_adr,intern_bases,undefined,ownerlist);
movearea(packfile,segm_pointer,undefined,
_ security_file,0,undefined,
_ maxbufsegm,packcat.areasize);
end;
<* opdatering af packentry *>
old_address := packcat.storeaddress;
packcat.storeaddress:= segm_pointer;
packcat_updated := true;
write(ud,"sp",5,<:repack ok:>);
if secu_tail(1) > 0 then cut_securityfile;
segm_pointer:= segm_pointer + packcat.areasize;
swop_cat(packcat,packcat_updated,gapcat,gapcat_updated);
end flyt areal
else
segm_pointer:= segm_pointer + entry_tab(entryused,3);
entryused:= entryused + 1;
end no_of_entries;
head.packfile_size:= segm_pointer;
set_packtail(head,pack_tail,0);
if head.extend_mark > 0 then
head.extend_mark := 0;
head.last_function:= 0;
if secu_tail(1) > -1 then
begin
i:= monitor(48)remove_entry:(secu,0,secu_tail);
if i <> 0 then
monitor_error(48,secu,i,false);
end;
end repack;
\f
procedure pointpack;
<******************>
<*
opretter entries, som peger på
de relevante områder i packfilen,
på baggrundslager ud fra oplysninger i
packfilens katalog med scope = temp
hvis newscope ikke er angivet.
hvis changekit er angivet oprettes på
det navngivne baggrundslager dokument
*>
begin
long array
_ name(1:2);
integer array
_ saveentry(1:head.entrylength//2);
integer
_ create_result,
_ ix,
_ fileno,
_ nextname_adr;
boolean
_ ok,
_ found;
procedure create;
<***************>
begin
tofrom(saveentry,packcat.entrybase_adr,head.entrylength);
if saveentry.storeaddress > 0 then
begin
saveentry.entrytail(3):= saveentry.storeaddress;
for ix:=2, 4, 5 do
saveentry.entrytail(ix):= 0;
for ix:=1,2 do
saveentry.auxdocname(ix):= saveentry.documentname(ix);
for ix:=1, 2 do
saveentry.documentname(ix):= packfile(ix);
saveentry.areasize:= 1 shift 23 add 4; <* mode = 0, kind = 4 *>
create_result:= create_entry(saveentry,newkit,process_bases,newscope);
if create_result >= 0 then
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
if create_result = 1 then
write(ud,"sp",5,<:*** temp, no login resources:>);
<* statistikkerne opdateres *>
if -,system_packfile then
begin
packcat.no_of_point:= packcat.no_of_point + 1;
packcat.lastaccess_date:= date;
packcat_updated:= true;
end;
end
else
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
write(ud,"sp",5,case abs create_result of (
_ <:*** no resources:>,<:*** name conflict:>));
end;
end
else
begin
print_entry(ud,packcat.entrybase_adr,intern_bases,scope,normlist);
write(ud,"sp",5,<:*** not area entry:>);
end;
end create;
print_heading(ud,normlist);
nextname_adr:= 0;
for fileno:=1 step 1 until no_of_files do
begin
scope:= get_nextentryspec(name,nextname_adr);
found:=
if scope = undefined then
lookup_tableentry(packcat,name,ownerid,intern_bases,scope)
else
search_tableentry(packcat,name,ownerid,intern_bases,scope);
if found then create
else lookup_error(ud,name,scope,false,1);
end;
if scopeboo or no_of_subtext > 0 then
begin
while next_packentry(packcat,intern_bases,optionlist.subtext_adr,ownerid,scope)
do if packcat.storeaddress > 0 then create;
end;
end pointpack;
\f
procedure purgepack;
<******************>
<*
sletter alle entries
i packfilen, uanset
nøglekriterier, såfremt
de er ældre end <lastdate>
*>
begin
print_heading(ud,ownerlist);
purge(packcat,gapcat,lastdate,deletetype,true);
end purgepack;
\f
procedure convertpack;
write(out,<:<10>*** convertpack not implemented !:>);
\f
<* erklæring af buffere og hjælpezoner *>
zone
_ myself(1,1,stderror), <* egen process, ændring af katalogbase *>
_ packcat(128,1,testblok), <* til packfilens entry katalog *>
_ gapcat(if gapcat_used then 128 else 1,
_ 1,testblok); <* til packfilens hulkatalog *>
<*+2*>
integer array
_ transfer_table(1:blocktable_size,1:3); <* til test af bloktransporter *>
<*-2*>
boolean array
_ hashtable(1:if hashing_used then <* primær hashtabel til søgning *>
_ head.hashtable_size else 1),
_ linktable(1:if hashing_used then <* linker entries med samme hashnøgle *>
_ head.packentries else 1);
integer
_ packcat_leftblock, <* gemmer resterende bytes i akt. blok *>
_ gapcat_leftblock, <* do *>
_ hashkey_computed, <* gemmer allerede beregnet hashnøgle *>
_ status, <* statusord til test af transporter *>
_ count, <* hjælpevariabel *>
_ help; <* hjælpevariabel *>
boolean
_ exit, <* styrevariabel ved fejlafvikling *>
_ packcat_updated, <* angiver om packcat blok er opdateret *>
_ gapcat_updated; <* angiver om gapcat blok er opdateret *>
<*+2*>
<* testvariable *>
integer
_ bloktransfer,
_ datatransfer,
_ segmtransfer;
bloktransfer:=
datatransfer:=
segmtransfer:= 0;
<*-2*>
\f
<* intialisering af styrevariable *>
exit :=
packcat_updated:=
gapcat_updated := false;
\f
<* h o v e d p r o g r a m *>
<* bestemmelse af maksimale bufferlængde for flytning af arealer *>
begin
real array ra(1:2);
max_bufsegm := (system(2,0,ra) - 5000) // 512;
if max_bufsegm <= 0 then max_bufsegm := 1 ;
<*+2*>
if test shift(-3) then
write(out,"nl",2,<:free core for main programrun =:>,system(2,0,ra),
_ "nl",2,<:max. buffer segments =:>,max_bufsegm);
<*-2*>
end;
<*+2*>
if test shift(-3) then
status:=1 shift 1 else
<*-2*>
status:=0;
<*+2*>
if test shift(-3) then
for count:=1 step 1 until head.first_areasegm - 1 do
for help :=1, 2, 3 do
transfer_table(count,help):= 0;
<*-2*>
<* der åbnes til katalogerne *>
open(myself,0,<::>,0);
open(packcat,4,packfile,status);
if gapcat_used then
open(gapcat,4,packfile,status);
<* nu kan den egentlige afvikling begynde *>
if -,current_output
then connect(ud,outfile,1);
write(ud,"nl",1,programname,<:, packfile = :>,packfile,<:, :>);
print_date(ud,packtail(6));
if ownerid(1) <> empty
then write(ud,<:<10>owner.:>,ownerid);
if newscope <> undefined
then write(ud,<:<10>newscope.:>, case newscope + 1 of
_ (<:temp:>,<:login:>,<:user:>,<:project:>));
if newkit(1) <> empty then
write(ud,<:<10>changekit.:>,newkit);
if viewbase_set then
write(ud,<:<10>base.:>,<<d>,viewbases(1),<:.:>,viewbases(2));
if remove then write(ud,<:<10>remove.yes:>);
<* owner skal angives ved public packfile *>
if packfile(1) = long <:publi:> add 'c' and packfile(2) = long <:pack:>
and ownerid(1) = empty
and -,allowner
and -,allpackfile
and program_function <> repacksym
and program_function <> purgepacksym
then
break(<:*** on publicpack owner must be specified:>,0,true);
<* det testes om packfilen har været udsat for ukorrekt afslutning *>
if head.extend_mark = 1 then
recompute_hashkeys(true);
if head.update_mark = 0 then
head.update_mark:= if check_packfile_head(head,packtail) then 1 else 0
else
check_packfile_head(head,packtail);
if head.update_mark = 1 then
head.update_mark:= if check_catalogs(head,packtail) then 1 else 0;
if program_function <> searchpacksym then
begin
if head.update_mark = 0 and -,system_packfile then
begin
if head.last_function <> repacksym then <* repack sætter selv last_function til 0 ! *>
head.last_function := program_function;
head.update_mark := 1;
setposition(head,0,0);
swoprec6(head,512);
end
else
if head.update_mark = 1 then
break(<:*** contents of packfile not ok - please consult users manual !:>,0,true);
end;
<* det undersøges om en evt. tidligere repack ikke er afsluttet *>
if head.last_function = repacksym
and program_function <> repacksym
and program_function <> searchpacksym
then break(<:*** previous repack not finished - must be run again !:>,0,true);
trap(abort);
if hashing_used
then initialize_hashtables(packcat);
<* automatisk sletning af entries *>
if program_function = repacksym
and dim_retention > 0
then head.retentiondays:= dim_retention;
if head.retentiondays < maxint and head.lastupdate < date and gapcat_used then
begin
purge(packcat,gapcat,compute_last_date(date,head.retentiondays),3,false);
head.lastupdate:= date;
end;
empty_out(out); <* generede udskrifter afsendes *>
if -,current_output then outchar(ud,'nl');
case program_function of
begin
pack;
unpack;
searchpack;
clearpack;
repack;
pointpack;
purgepack;
convertpack;
end case program_function;
if (program_function = packsym
or program_function = clearpacksym
or program_function = purgepacksym)
and head.no_of_gaps > 0
then reorganize_gapcat(gapcat);
if head.update_mark = 1
and program_function <> searchpacksym
then head.update_mark:= 0;
if false then
abort:
begin
exit:= true;
if alarmcause extract 24 <> -9
and trapmode <> -1
then
begin
<*+2*>
test:= test shift(-1) shift 1 add 1;
<*-2*>
write(out,"nl",3,
_ <:----------------------------------------------------<10>:>,
_ <:! *** program funktionsfejl - bør fejlmeldes !!! !<10>:>,
_ <:! - Henvendelse til systemvedligeholdelses !<10>:>,
_ <:! - personalet på Handelshøjskolens Datacenter. !<10>:>,
_ <:! - Vedlæg denne udskrift - på forhånd tak ! !<10>:>,
_ <:----------------------------------------------------<10>:>);
end;
trapmode:= 0;
check_transfer(packcat,packcat_updated);
if gapcat_used then
check_transfer(gapcat,gapcat_used);
if program_function = packsym
or program_function = repacksym then
set_packtail(head,packtail,0);
end;
close(head,true);
newposition(packcat,0,packcat_updated,packcat_leftblock);
close(packcat,true);
if gapcat_used then
begin
newposition(gapcat,0,gapcat_updated,gapcat_leftblock);
close(gapcat,true);
end;
trap(0);
if exit then
write(out,"nl",2,<:*** run abort, packfile was closed correctly:>,"nl",1);
write(ud,"nl",2,programname,<: end:>,"nl",1);
if convert or -,current_output then
outchar(ud,'em');
if -,current_output then
close(ud,true);
if convert then
print_area(ud,0);
<*+2*>
if test shift(-5) then
begin
cputime:= systime(1,timebase,realtime) - cputime;
write(out,"nl",2,<<ddddd.dd>,<:cputime =:>,cputime,
_ <:, realtime =:>,realtime);
end;
if test then
begin
open(head,4,packfile,0);
open(packcat,4,packfile,0);
print_packhead(head);
if hashing_used then print_tables;
print_packcat_(packcat);
print_gapcat__(packcat);
close(head,true);
close(packcat,true);
end;
if test shift(-3) then
begin
write(out,"ff",1,"nl",2,<:bloktransporter til/fra kataloger:>,"nl",2);
write(out,<:segmno inrec6 outrec6 swoprec6<10>:>);
for count:=1 step 1 until blocktable_size do
begin
write(out,"nl",1,<<dddddd>,count);
for help:=1, 2, 3 do
write(out,<<ddddddddd>,transfer_table(count,help));
end;
write(out,"nl",2,
_ <:<10>transporter af katalogsegmenter =:>,bloktransfer,
_ <:<10>transporter af datablokke =:>,datatransfer,
_ <:<10>transporter af datasegmenter =:>,segmtransfer);
end;
<*-2*>
end procedure main;
\f
zone
_ pack_head(128,1,stderror); <* indeholder packfilens hovede (segmno. 0 *>
long array
_ optionlist(1:maxindex); <* indeholder den indlæste parameterliste *>
integer
_ blocktable_size,
_ count;
\f
<* her starter den egentlige programafvikling *>
<* ========================================== *>
<* dato beregnes *>
cputime:= systime(1,0.0,timebase);
date := systime(4,timebase,0.0);
<* programkaldet læses, parameterlisten testes og analyseres *>
read_program_call;
<* baserne for den aktuelle kørende process bestemmes *>
system(11,0,process_bases);
system(11,0,intern_bases);
<* std. baser og katalog baser lægges på min. user base *>
if intern_bases(3) > intern_bases(5) then
begin
intern_bases(4):= intern_bases(4) - (intern_bases(3) - intern_bases(5));
intern_bases(3):= intern_bases(5);
end;
if intern_bases(1) > intern_bases(5) then
begin
intern_bases(2):= intern_bases(2) - (intern_bases(1) - intern_bases(5));
intern_bases(1):= intern_bases(5);
end;
if viewbase_set then
for count:= 3, 5, 7 do
begin
intern_bases(count) := viewbases(1);
intern_bases(count + 1) := viewbases(2);
end;
lower_catbase:= process_bases(1);
upper_catbase:= process_bases(2);
<*+1*>
if test shift(-2) then
write(out,<:<10><10>intern process bases:<10>:>,
_ <:<10>std. bases::>,<< -ddddddd>,intern_bases(3),intern_bases(4),
_ <:<10>user bases::>,intern_bases(5),intern_bases(6),
_ <:<10>max. bases::>,intern_bases(7),intern_bases(8));
<*-1*>
<* test af ressourcer *>
ressource_check(<* size *> 16384, <* buf *> 2, <* area *> 4);
<* der åbnes til packfilen, ved pack oprettes denne evt. *>
initialize_packfile_head(pack_head);
<*
nu afvikles hovedprogrammet og proceduren main
kaldes afhængig af om kørselsoversigten ønskes
på current output eller specificeret medium
*>
<*+2*>
if test shift(-3) then
blocktable_size:= packhead.first_areasegm - 1 else
<*-2*>
blocktable_size:= 1;
if current_output
then main(out,pack_head)
else
begin
zone overs(128,1,stderror);
main(overs,pack_head);
end;
end global programblok;
end
▶EOF◀