<> DIRECTORY FS USING [Error, StreamOpen], Booting USING [CheckpointProc, RegisterProcs, RollbackProc], Convert USING [RopeFromCard], DB, DBIcons, IO, Basics USING[LowHalf], IOClasses USING [CreateCommentFilterStream ], NutOps USING[ EntityToName, Separator ], Icons USING [NewIconFromFile, IconFlavor], List USING[ DotCons, DottedPair, AList ], MessageWindow USING [Append, Blink], Process USING[Ticks, SecondsToTicks, Detach, Pause], VM USING [AddressFault], Rope USING [Cat, Equal, Length, SkipTo, ROPE], UserProfile USING [ Token ] ; DBIconsImpl: CEDAR MONITOR IMPORTS Basics, Booting, FS, Convert, IO, MessageWindow, VM, Process, Rope, Icons, DB, List, UserProfile, NutOps, IOClasses EXPORTS DBIcons = BEGIN OPEN DB, Rope; <> Failed: PUBLIC ERROR [why: DBIcons.Failure, reason: Rope.ROPE] = CODE; ROPE: TYPE = Rope.ROPE; <> IconDomain: DB.Domain; -- the domain of icons IconRelation: DB.Relation; -- the relation giving the properties of an icon <> IconFileAttr: DB.Attribute; -- the name of the file for an icon IconIndexAttr: DB.Attribute; -- the index in the file IconIsAttr: DB.Attribute; -- the icon itself (the other attributes are treated as properties) iconCache: List.AList _ NIL; -- the internal cache of mappings from icon names to flavors IconDB: PUBLIC ROPE _ NIL; readOnly: PUBLIC BOOLEAN _ TRUE; -- true if the segment is readonly activity: BOOLEAN _ FALSE; -- true if a database operation has been performed recently ticksToWait: Process.Ticks _ Process.SecondsToTicks[5*60]; schemaSet: CONDITION; <> EstablishIconDB: PUBLIC PROC [file: Rope.ROPE _ NIL] = { IconDB _ IF file = NIL THEN UserProfile.Token[key: "Icons.Segment", default: "[Luther.Alpine]Icons.Segment"] ELSE file; ResetSchema[]; iconCache _ NIL }; WatchDBActivity: PROC[] = { WHILE TRUE DO Process.Pause[ticksToWait]; CheckConnection[] ENDLOOP }; CheckConnection: ENTRY PROC[] = { IF NOT activity THEN { trans: DB.Transaction = DB.TransactionOf[$Icons]; IF trans # NIL THEN DB.CloseTransaction[trans] }; -- don't keep the connection open too long activity _ FALSE; }; <> RegisterIcon: PUBLIC ENTRY PROC [iconName: Rope.ROPE, fileName: Rope.ROPE, index: CARDINAL] = { <> [] _ InternalRegisterIcon[iconName, fileName, index] }; GetIcon: PUBLIC ENTRY PROC [iconName: Rope.ROPE, default: Icons.IconFlavor _ unInit] RETURNS [Icons.IconFlavor] = { <> <> ENABLE UNWIND => NULL; cachedFlavor: REF ANY = CheckCache[iconName, iconCache]; flavor: Icons.IconFlavor _ unInit; success: BOOL; DoGetIcon: PROC[] = { icon: Entity = DeclareEntity[IconDomain, iconName, OldOnly]; IF icon = NIL THEN {flavor _ default; RETURN}; { fileName: ROPE = V2S[ GetP[ icon, IconFileAttr, IconIsAttr ] ]; index: CARDINAL = Basics.LowHalf[LOOPHOLE[V2I[GetP[icon, IconIndexAttr, IconIsAttr]]]]; flavor _ Icons.NewIconFromFile[fileName, index ! FS.Error => IF default # unInit THEN flavor _ default ELSE ERROR Failed[fileNotFound, fileName]; VM.AddressFault => IF default # unInit THEN flavor _ default ELSE ERROR Failed[invalidIndex, Convert.RopeFromCard[index]]]; -- NewIconFromFile raises this if given badindex. } }; IF cachedFlavor # NIL THEN RETURN[NARROW[cachedFlavor, REF Icons.IconFlavor]^]; IF IconDB = NIL THEN RETURN[default]; success _ CarefullyApply[DoGetIcon]; IF NOT success THEN RETURN[default]; IF flavor # unInit THEN { iconCache _ Cache[ List.DotCons[iconName, NEW[Icons.IconFlavor _ flavor]], iconCache ]; RETURN[flavor] }; IF default # unInit THEN RETURN[default]; ERROR Failed[noSuchIcon, iconName] }; <<****************** setting/getting icons for entities **************** -- works for Entities or Domains >> acorn: Icons.IconFlavor_ NewIcon["Nut.icons", 3]; SetIcon: PUBLIC PROCEDURE[e: Entity, iconFile: ROPE, fileIndex: CARDINAL] = BEGIN name: ROPE = IF DB.Eq[DomainOf[e], DomainDomain] THEN DB.NameOf[e] ELSE NutOps.EntityToName[e, DB.SegmentOf[e]]; IF IsRegistered[name].file = NIL THEN RegisterIcon[ name, iconFile, fileIndex ] END; icons: IconList; IconList: TYPE = LIST OF RECORD[file: ROPE, index: INTEGER, icon: Icons.IconFlavor]; NewIcon: PUBLIC PROC[file: ROPE, index: INTEGER] RETURNS[icon: Icons.IconFlavor _ acorn] = BEGIN ENABLE FS.Error => TRUSTED {IF error.group = bug OR error.group = environment THEN REJECT ELSE GOTO notFound}; FOR list: IconList _ icons, list.rest WHILE list # NIL DO IF list.first.index # index THEN LOOP; IF ~Rope.Equal[list.first.file, file] THEN LOOP; RETURN[list.first.icon]; ENDLOOP; icon _ Icons.NewIconFromFile[file, index]; icons _ CONS[[file, index, icon], icons]; EXITS notFound => -- if not given full path name, then try [Indigo]Icons>file BEGIN ENABLE FS.Error => TRUSTED {IF error.group = bug OR error.group = environment THEN REJECT ELSE CONTINUE}; IF file.SkipTo[pos: 0, skip: "[/"] # file.Length[] THEN RETURN; --given full path, give up icon _ Icons.NewIconFromFile[Rope.Cat["[Indigo]Icons>", file], index]; icons _ CONS[[file, index, icon], icons]; END; END; Cache: INTERNAL PROC[ pair: List.DottedPair, aList: List.AList ] RETURNS[ List.AList ] = { x, x1: List.AList _ NIL; x _ aList; UNTIL x = NIL DO IF Rope.Equal[NARROW[x.first.key, ROPE], NARROW[pair.key, ROPE]] THEN BEGIN x.first.val _ pair.val; RETURN[aList]; END; x1_x; x _ x.rest; ENDLOOP; <> x _ CONS[pair, NIL]; IF x1 = NIL THEN RETURN[x] ELSE IF x1.rest = NIL THEN x1.rest _ x -- add at end ELSE ERROR ; -- defensive programming RETURN[aList]; }; CheckCache: INTERNAL PROC[ name: Rope.ROPE, in: List.AList ] RETURNS[ val: REF ANY ] = { UNTIL in = NIL DO IF Rope.Equal[NARROW[in.first.key, Rope.ROPE], name] THEN RETURN[in.first.val]; in _ in.rest; ENDLOOP; RETURN[NIL]}; IsRegistered: PUBLIC ENTRY PROC[iconName: Rope.ROPE _ NIL, fileName: Rope.ROPE _ NIL, index: CARDINAL _ LAST[CARDINAL]] RETURNS[name: Rope.ROPE, file: Rope.ROPE, i: CARDINAL] = { <> DoRegisterCheck: PROC[] = { IF iconName # NIL THEN { icon: Entity = DeclareEntity[IconDomain, iconName, OldOnly]; IF icon = NIL THEN { file _ NIL; name _ NIL; i _ 0 } ELSE { file _ V2S[ GetP[ icon, IconFileAttr, IconIsAttr ] ]; i _ Basics.LowHalf[LOOPHOLE[V2I[GetP[icon, IconIndexAttr, IconIsAttr]]]] } } ELSE {iconRels: RelshipSet = RelationSubset[IconRelation, LIST[AttributeValue[IconFileAttr, S2V[fileName]], AttributeValue[IconIndexAttr, U2V[index]]]]; iconRel: Relship = NextRelship[iconRels]; IF iconRel = NIL THEN { ReleaseRelshipSet[iconRels]; file _ NIL; name _ NIL; i _ 0 } ELSE { name _ DB.NameOf[V2E[GetF[iconRel, IconIsAttr]]]; file _ fileName; i _ index; ReleaseRelshipSet[iconRels] } } }; IF NOT CarefullyApply[DoRegisterCheck] THEN RETURN[NIL, NIL, 0] }; InvalidateCache: PUBLIC ENTRY PROC [iconName: Rope.ROPE _ NIL] = { <> IF iconName = NIL THEN iconCache _ NIL ELSE iconCache _ Cache[ List.DotCons[iconName, NIL], iconCache ] }; InternalRegisterIcon: INTERNAL PROC[iconName: Rope.ROPE, fileName: Rope.ROPE, index: CARDINAL] RETURNS[success: BOOLEAN] = { p: SAFE PROCESS _ NIL; DoRegisterIcon: PROC[] = { icon: DB.Entity = DeclareEntity[IconDomain, iconName]; iconRel: Relship = DeclareRelship[ IconRelation, LIST[AttributeValue[IconIsAttr, icon]] ]; SetF[iconRel, IconFileAttr, S2V[fileName]]; SetF[iconRel, IconIndexAttr, U2V[index]] }; IF readOnly OR IconDB = NIL THEN RETURN; -- can't register things in this segment p _ FORK ResetSchema[]; TRUSTED {JOIN p}; success _ CarefullyApply[DoRegisterIcon] }; <> Parse: INTERNAL PROCEDURE[ stream: IO.STREAM, errlog: IO.STREAM ] = { OPEN IO; error: BOOLEAN _ FALSE; { ENABLE IO.EndOfStream => GOTO Out; DO sepCount: INT; DBNameProc: IO.BreakProc = { <> <> IF char = NutOps.Separator THEN { sepCount _ sepCount+1; RETURN[other] }; IF char = ': AND (sepCount = 2 OR sepCount = 0) THEN RETURN[sepr]; RETURN[other] }; whiteSpace: IO.BreakProc = { RETURN[ SELECT char FROM CR => break, IO.SP, IO.ESC, IO.LF, IO.TAB, ',, ':, '; => sepr, ENDCASE => other ] }; isACR: IO.BreakProc = { RETURN[IF char = CR THEN break ELSE other] }; tokenProc: IO.BreakProc = { RETURN[SELECT char FROM IO.SP, IO.TAB, ', => sepr, IO.CR => break, ENDCASE => other ]; }; iconName, fileName: Rope.ROPE; index: CARDINAL; position: INT; [] _ IO.SkipWhitespace[stream]; position _ stream.GetIndex[]; sepCount _ 0; iconName _ IO.GetTokenRope[stream, DBNameProc].token; fileName _ IO.GetTokenRope[stream, whiteSpace].token; index _ IO.GetCard[stream]; IF NOT InternalRegisterIcon[iconName, fileName, index] THEN { error _ TRUE; Report[msg: Rope.Cat["Transaction Aborted at: ", Convert.RopeFromCard[position]], errLog: errlog]; GOTO Out } ENDLOOP; EXITS Out => NULL; }; IF error THEN { MessageWindow.Append["problems encountered in reading icon file."]; MessageWindow.Blink[]; IF errlog # NIL THEN errlog.Close[]; }; }; WriteCatalogue: PUBLIC ENTRY PROC [file: Rope.ROPE] = { stream: IO.STREAM; InternalWrite: PROC[] = { OPEN IO; icons: EntitySet = DomainSubset[IconDomain]; FOR e: Entity _ NextEntity[icons], NextEntity[icons] UNTIL e = NIL DO fileName: ROPE = V2S[ GetP[e, IconFileAttr, IconIsAttr] ]; index: CARDINAL = Basics.LowHalf[LOOPHOLE[V2I[GetP[e, IconIndexAttr, IconIsAttr]]]]; stream.PutF["\n%g: %g %d", rope[DB.NameOf[e]], rope[fileName], int[index]]; ENDLOOP; stream.Close[] }; stream _ FS.StreamOpen[file, $append ! FS.Error => {stream _ NIL; CONTINUE}]; IF stream # NIL THEN [] _ CarefullyApply[InternalWrite] }; <> Report: INTERNAL PROCEDURE [msg: Rope.ROPE, errLog: IO.STREAM] = { OPEN IO; IF errLog # NIL THEN errLog.PutF["\n\n%g", rope[msg]]; }; <> OpenUp: Booting.RollbackProc = { DB.Initialize[nCachePages: 256]; InvalidateCache[] }; CloseTrans: Booting.CheckpointProc = { DB.CloseTransaction[trans: DB.TransactionOf[segment: $Icons]] }; ResetSchema: ENTRY PROC[] = { success: BOOLEAN; activity _ TRUE; IF DB.TransactionOf[$Icons] # NIL THEN RETURN; [success, readOnly] _ SetUpSegment[]; IF NOT success THEN RETURN; IF NOT DB.Null[IconDomain] THEN { BROADCAST schemaSet; RETURN }; -- all is well, don't bother flushing cache IconDomain _ DeclareDomain["Icon", $Icons]; IconRelation _ DeclareRelation[ "IconInfo", $Icons ]; IconFileAttr _ DeclareAttribute[IconRelation, "file", RopeType]; IconIndexAttr _ DeclareAttribute[IconRelation, "index", IntType]; IconIsAttr _ DeclareAttribute[IconRelation, "of", IconDomain, Key]; iconCache _ NIL; BROADCAST schemaSet }; ReadCatalogue: PUBLIC ENTRY PROC[file: Rope.ROPE, errlog: IO.STREAM _ NIL] = TRUSTED { stream: IO.STREAM; stream _ FS.StreamOpen[file ! FS.Error => { stream _ NIL; CONTINUE }]; IF stream = NIL THEN RETURN; stream _ IOClasses.CreateCommentFilterStream[stream]; Parse[ stream, errlog ]; DB.MarkTransaction[DB.TransactionOf[$Icons]] }; CarefullyApply: INTERNAL PROC [proc: PROC[]] RETURNS [succeeded: BOOL] ~ { ENABLE DB.Error, DB.Failure, DB.Aborted => {succeeded _ FALSE; GOTO Quit}; p: SAFE PROCESS _ NIL; transactionToBeAborted: DB.Transaction _ NIL; succeeded _ TRUE; proc[ ! DB.Aborted => { DB.AbortTransaction[trans]; succeeded _ FALSE; CONTINUE }; DB.Error => {IF code # TransactionNotOpen THEN REJECT; succeeded _ FALSE; CONTINUE} ]; IF succeeded = TRUE THEN RETURN; -- no aborted occurred, things either succeeded or failed <> IF transactionToBeAborted # NIL THEN DB.AbortTransaction[transactionToBeAborted]; TRUSTED { Process.Detach[ FORK ResetSchema[] ] }; WAIT schemaSet; -- ResetSchema is doing its job since we forked it proc[]; -- don't bother trying to restart here -- EXITS Quit => NULL; }; SetUpSegment: INTERNAL PROC [] RETURNS [success: BOOL, readOnly: BOOL] ~ { ENABLE DB.Aborted, DB.Failure, DB.Error => {success _ FALSE; CONTINUE}; segment: ATOM = $Icons; readOnly _ FALSE; success _ TRUE; DB.Initialize[nCachePages: 256]; IF DB.TransactionOf[segment] # NIL THEN {readOnly_ DB.GetSegmentInfo[segment].readOnly; RETURN}; DB.DeclareSegment[IconDB, segment, 140B, FALSE]; DB.OpenTransaction[segment ! DB.Error => TRUSTED { success_ FALSE; SELECT code FROM ProtectionViolation => {readOnly _ TRUE; CONTINUE}; ENDCASE => GOTO AlreadyDone} ]; IF success THEN GOTO AlreadyDone; <> DB.CloseTransaction[DB.TransactionOf[segment]]; DB.DeclareSegment[IconDB, segment, 140B, TRUE]; DB.OpenTransaction[segment]; IF NOT success THEN DB.CloseTransaction[DB.TransactionOf[segment]] EXITS AlreadyDone => NULL }; <> TRUSTED { Booting.RegisterProcs[c: CloseTrans, r: OpenUp]; EstablishIconDB[]; Process.Detach[ FORK WatchDBActivity[] ] }; END. <<>>