home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Think Class Libraries / TP TCL->CW TCL v1.1.2.3 / TCL.p < prev   
Encoding:
Text File  |  1996-04-25  |  126.4 KB  |  4,139 lines  |  [TEXT/CWIE]
  1. {****************************************************************************}
  2. {    TCL.p}
  3. {}
  4. {    Interface for the Core TCL classes}
  5. {}
  6. {        Copyright © 1989-1991 Symantec Corporation. All rights reserved.}
  7. {}
  8. {****************************************************************************}
  9.  
  10. {TCL VERSION 1.1.2.3 - APRIL 25 1996}
  11. {CAN BE COMPILED USING METROWERKS PASCAL COMPILERS}
  12.  
  13. unit TCL;        { Core TCL classes    }
  14.  
  15. interface
  16.  
  17. uses
  18.     AppleEvents, Balloons, Exceptions, Windows, StandardFile, types, TextUtils, ToolUtils;
  19.  
  20. {**************************************************}
  21. { Globals}
  22. {}
  23. {        Commonly used constants, type definitions, and variables. }
  24. {}
  25. {**************************************************}
  26.  
  27. const
  28.  
  29.     MININT = (-maxint) - 1;                    { Mininum int value                }
  30.     MINLONG = (-maxlongint) - 1;            { Minimum longint value         }
  31.     NOTHING = 0;                            { Useful flag                    }
  32.  
  33.     xInts = (maxint div sizeof(integer)) - 1;        { Used in array type     }
  34.     xLongs = (maxint div sizeof(longint)) - 1;        { definitions below        }
  35.  
  36. type
  37.  
  38.     BytePtr = ^Byte;
  39.     IntPtr = ^integer;
  40.     LongPtr = ^longint;
  41.  
  42.     PointPtr = ^Point;
  43.  
  44.     RectPtr = ^Rect;
  45.     RectHandle = ^RectPtr;
  46.  
  47.     IntArrayP = ^IntArray;
  48.     IntArrayH = ^IntArrayP;
  49.     IntArray = array[0..xInts] of integer;
  50.  
  51.     LongArrayP = ^LongArray;
  52.     LongArrayH = ^LongArrayP;
  53.     LongArray = array[0..xLongs] of longint;
  54.  
  55.     DimOption = (dimNONE, dimSOME, dimALL);    {    Used by Bartender    }
  56.  
  57.     CharPtr = ^char;
  58.  
  59.     tSystem = packed record
  60.             hasWNE: BOOLEAN;
  61.             hasColorQD: BOOLEAN;
  62.             hasGestalt: BOOLEAN;
  63.             hasAppleEvents: BOOLEAN;
  64.             hasAliasMgr: BOOLEAN;
  65.             hasEditionMgr: BOOLEAN;
  66.             hasHelpMgr: BOOLEAN;
  67.             hasScriptMgr: BOOLEAN;
  68.             hasFPU: BOOLEAN;
  69.             scriptsInstalled: Integer;
  70.             systemVersion: Integer;
  71.         end;
  72.  
  73. var
  74.  
  75.     nullStr: Str255;
  76. (*    MenuDisable: LongPtr;        { Low-memory global }*)
  77.     gSystem: tSystem;
  78.  
  79. {**************************************************}
  80. { Constants}
  81. {}
  82. {        Constants used in the THINK Class Library}
  83. {}
  84. {**************************************************}
  85.  
  86. const
  87.  
  88.     STRcommon = 128;                { STR# resource ID for commonly    }
  89.                                     {   used strings                }
  90.  
  91.     strQUITTING = 1;
  92.     strCLOSING = 2;
  93.     strUNDO = 3;
  94.     strREDO = 4;
  95.     strUNTITLED = 5;
  96.     strSHOWCLIP = 6;
  97.     strHIDECLIP = 7;
  98.  
  99.     STRmemWarn = 129;            { Strings for low memory warnings        }
  100.     iMEM_LOW = 1;
  101.  
  102.     MBARapp = 1;                { Menu Bar Resource ID                    }
  103.  
  104.     MINIMUM_BALANCE = 2048;        { Minimum memory reserve                }
  105.  
  106.     CMD_DELIMITER = '#';        { Separates menu item name from cmd no.    }
  107.     DEFAULT_DIM = dimALL;        { Default DimOption for menus            }
  108.  
  109.     WIND_CLIPBOARD = 200;        { Clipboard window resource ID            }
  110.  
  111.                                 { Button Numbers in Alerts }
  112.     answerYES = 1;
  113.     answerNO = 2;
  114.     answerCANCEL = 3;
  115.  
  116.     DRAG_MARGIN = 4;            { Margin around desktop when        }
  117.                                 {   dragging a window                }
  118.  
  119.     REASONABLY_CLOSE = 5;        { How close two points must be to    }
  120.                                 { be part of a multi-click on        }
  121.                                 {   the Desktop                        }
  122.  
  123.                                 { CDecorator Parameters }
  124.  
  125.     MAX_WOFFSETS = 5;            { Max depth of offsetting windows    }
  126.     LEFT_SMARGIN = 4;            { Margin at left of screen            }
  127.     TOP_SMARGIN = 22;            { Margin at top of screen            }
  128.     RIGHT_SMARGIN = 4;            { Margin at right of screen            }
  129.     BOTTOM_SMARGIN = 4;            { Margin at bottom of screen        }
  130.     HORIZ_WOFFSET = 8;            { Horizontal window offset            }
  131.     VERT_WOFFSET = 16;            { Vertical window offset            }
  132.  
  133.     STRprompt = 150;            { STR resource ID of prompt string    }
  134.                                 {   when doing a SaveAs                }
  135.  
  136.     ALRTrevert = 150;            { Alert to confirm revert to saved    }
  137.     ALRTsaveChanges = 151;        { Save changes before close/quit    }
  138.     STRtaskNames = 130;            { STR# resource ID for task names    }
  139.  
  140.     ALRTgeneral = 128;            { Generic Alert box                    }
  141.     ALRTsevereErr = 200;        { Alert box for a Severe Error        }
  142.     ALRTosError = 300;            { Alert box for a Mac OS Error        }
  143.     ALRT_NOPRINTER = 250;        { Alert when there is no printer    }
  144.     STRosError = 300;            { Generic Mac OS error message        }
  145.     ErrMsg_Res = 'Estr';        { Resource type for list of error    }
  146.                                 {   message string corresponding    }
  147.                                 {   to Mac OS Errors/result codes    }
  148.  
  149.     STR_TCLfailMsgs = 131;        { STR# resource ID for failure     }
  150.                                 { messages    for TCL                    }
  151.     kUserFailMsgBase = 1024;    { programmer defined failure msgs    }
  152.                                 { are specified from a base value     }
  153.                                 { of 1024                            }
  154.     STRdlgValidation = 133;        { STR# resource ID for dialog        }
  155.                                 { validation errors                }
  156.  
  157.     ALRTvalidation = 129;        { Alert box for dialog validation  }
  158.     ALRT_Exception = 251;        { Alert used by exception handler  }
  159.     ALRT_ExceptionAbort = 252;    { Exception alert used when aborting app }
  160.     STRosError2 = 301;            { ErrorAlert's Mac OS error message}
  161.  
  162.  
  163.     CNTL_SBAR = 300;            { CNTL Resource ID of a scroll bar    }
  164.  
  165.     PAGE_DELAY = 10;            { Ticks to delay during continuous    }
  166.                                 {   page scrolling                    }
  167.  
  168.     SIZEBOX_LENGTH = 16;        { Length of a size box in pixels    }
  169.     SICN_SIZEBOX = 200;            { SICN Resource ID for size box        }
  170.  
  171.     MIN_WSIZE = 100;            { Minimum size of a window            }
  172.  
  173.     SBARSIZE = 16;                { Size of a scroll bar in pixels    }
  174.     SBARSIZE1 = 15;                { SBARSIZE - 1                        }
  175.  
  176.     OBJ_WINDOW_KIND = 1001;        { windowKind for a Mac window        }
  177.                                 { associated with a CWindow object    }
  178.  
  179.     pascalKind = 32700;            { THINK Pascal's windows have a     }
  180.                                 { windowKind >= 32700                 }
  181.  
  182.     kDefaultHelpResID = 128;     { default ID for 'hrct' help  balloon resource }
  183.     TCL_SICN = 200;                { resource ID for SICN used by TCL    }
  184.     POPUP_SICN = 2;                { index into SICN 200 for popup arrow }
  185.  
  186.     STD_PAGE_WIDTH = 576;        { Default pixel width of a page        }
  187.     STD_PAGE_HEIGHT = 720;        { Default pixel height of a page    }
  188.  
  189.     SYS_FONT_SIZE = 12;            { Size of System font                }
  190.  
  191.     CARRIAGE_RETURN = chr(13);    { Character code                    }
  192.  
  193.  
  194.     KeyHome = $73;                { Key code for Home key                }
  195.     KeyEnd = $77;                { Key code for End key                }
  196.     KeyPageUp = $74;            { Key code for Page Up key            }
  197.     KeyPageDown = $79;            { Key code for Page Down key        }
  198.  
  199.     kEnterKey = chr(3);            { ASCII code for Enter key            }
  200.     kBackspaceKey = chr(8);
  201.     kTabKey = chr(9);
  202.     kReturnKey = chr(13);
  203.     kEscapeOrClear = chr($1B);    { ASCII code for both Escape and Clear keys }
  204.     kLeftCursor = chr(28);
  205.     kRightCursor = chr(29);
  206.     kUpCursor = chr(30);
  207.     kDownCursor = chr(31);
  208.  
  209.     KeyEscape = $35;        { Key code for Escape key            }
  210.     KeyClear = $47;            { Key code for Clear key            }
  211.     KeyHelp = $72;            { Key code for Help key            }
  212.     KeyFwdDelete = $75;        { Key code for Forward Delete        }
  213.     KeyLeftCursor = $7B;    { Key code for cursor left            }
  214.     KeyRightCursor = $7C;    { Key code for cursor right        }
  215.     KeyUpCursor = $7E;        { Key code for cursor up            }
  216.     KeyDownCursor = $7D;    { Key code for cursor down            }
  217.     KeyF1 = $7A;            { Key code for F1                    }
  218.     KeyF2 = $78;            { Key code for F2                    }
  219.     KeyF3 = $63;            { Key code for F3                    }
  220.     KeyF4 = $76;            { Key code for F4                    }
  221.     KeyF5 = $60;            { Key code for F5                    }
  222.     KeyF6 = $61;            { Key code for F6                    }
  223.     KeyF7 = $62;            { Key code for F7                    }
  224.     KeyF8 = $64;            { Key code for F8                    }
  225.     KeyF9 = $65;            { Key code for F9                    }
  226.     KeyF10 = $6D;            { Key code for F10                    }
  227.     KeyF11 = $67;            { Key code for F11                    }
  228.     KeyF12 = $6F;            { Key code for F12                    }
  229.     KeyF13 = $69;            { Key code for F13                    }
  230.     KeyF14 = $6B;            { Key code for F14                    }
  231.     KeyF15 = $71;            { Key code for F15                    }
  232. {*** M E N U S ***}
  233.  
  234.     MENUapple = 1;        { Apple menu with DAs, etc.         }
  235.     MENUfile = 2;        { File menu with New, Open, etc.     }
  236.     MENUedit = 3;        { Edit menu with Cut, Copy, etc.     }
  237.     MENUfont = 10;        { Menu of installed fonts             }
  238.     MENUsize = 11;        { Menu of font sizes                 }
  239.     MENUstyle = 12;        { Menu of font styles                }
  240.  
  241. {**************************************************}
  242. { Commands}
  243. {}
  244. {        Commands recognized by the THINK Class Library    }
  245. {}
  246. {        Command numbers 0 through 1023 are reserved for use by the TCL. }
  247. {}
  248. {**************************************************}
  249.  
  250. const
  251.  
  252.     cmdNull = 0;                { Command which does nothing    }
  253.  
  254.     cmdOK = 100;            { OK button in dialog box            }
  255.     cmdCancel = 101;        { Cancel button in dialog box        }
  256.  
  257.     cmdAbout = 256;            { About Application request        }
  258.  
  259.  
  260.                                     { Standard File Menu commands }
  261.     cmdQuit = 1;
  262.     cmdNew = 2;
  263.     cmdOpen = 3;
  264.     cmdClose = 4;
  265.     cmdSave = 5;
  266.     cmdSaveAs = 6;
  267.     cmdRevert = 7;
  268.     cmdPageSetup = 8;
  269.     cmdPrint = 9;
  270.  
  271.                                     { Standard Edit Menu commands }
  272.     cmdUndo = 16;
  273.     cmdCut = 18;
  274.     cmdCopy = 19;
  275.     cmdPaste = 20;
  276.     cmdClear = 21;
  277.     cmdToggleClip = 22;        { Show or Hide the Clipboard window    }
  278.     cmdSelectAll = 23;
  279.  
  280.                                     { Text Styles }
  281.     cmdPlain = 30;
  282.     cmdBold = 31;
  283.     cmdItalic = 32;
  284.     cmdUnderline = 33;
  285.     cmdOutline = 34;
  286.     cmdShadow = 35;
  287.     cmdCondense = 36;
  288.     cmdExtend = 37;
  289.  
  290.                                     { Text Alignment }
  291.     cmdAlignRight = 40;
  292.     cmdAlignLeft = 41;
  293.     cmdAlignCenter = 42;
  294.     cmdJustify = 43;
  295.  
  296.                                     { Line Spacing }
  297.     cmdSingleSpace = 50;
  298.     cmd1HalfSpace = 51;
  299.     cmdDoubleSpace = 52;
  300.  
  301. {****************************************************************************}
  302. {    Exceptions                                                                             }
  303. {****************************************************************************}
  304.  
  305. {****************************************************************************}
  306. { LongCoordinates}
  307. {****************************************************************************}
  308. type
  309.     LongPt = record
  310.             case INTEGER of
  311.                 1: (
  312.                         v: Longint;
  313.                         h: Longint
  314.                 );
  315.                 2: (
  316.                         vh: array[VHSelect] of Longint
  317.                 );
  318.         end;
  319.     LongPtPtr = ^LongPt;
  320.  
  321.     LongRect = record
  322.             case INTEGER of
  323.                 1: (
  324.                         top: Longint;
  325.                         left: Longint;
  326.                         bottom: Longint;
  327.                         right: Longint
  328.                 );
  329.                 2: (
  330.                         topLeft: LongPt;
  331.                         botRight: LongPt
  332.                 );
  333.         end;
  334.     LongRectPtr = ^LongRect;
  335.  
  336. procedure QDToLongPt (srcPt: Point; var destPt: LongPt);
  337. procedure LongToQDPt (srcPt: LongPt; var destPt: Point);
  338. procedure SetLongPt (var pt: LongPt; h: Longint; v: Longint);
  339. procedure AddLongPt (srcPt: LongPt; var destPt: LongPt);
  340. procedure SubLongPt (srcPt: LongPt; var destPt: LongPt);
  341. function EqualLongPt (pt1: LongPt; pt2: LongPt): Boolean;
  342. function PtInQDSpace (pt: LongPt): Boolean;
  343.  
  344. procedure QDToLongRect (srcRect: Rect; var destRect: LongRect);
  345. procedure LongToQDRect (srcRect: LongRect; var destRect: Rect);
  346. procedure SetLongRect (var r: LongRect; left: Longint; top: Longint; right: Longint; bottom: Longint);
  347. procedure OffsetLongRect (var r: LongRect; dh: Longint; dv: Longint);
  348. procedure InsetLongRect (var r: LongRect; dh: Longint; dv: Longint);
  349. function SectLongRect (src1: LongRect; src2: LongRect; var destRect: LongRect): Boolean;
  350. procedure UnionLongRect (src1: LongRect; src2: LongRect; var destRect: LongRect);
  351. function PtInLongRect (pt: LongPt; r: LongRect): Boolean;
  352. procedure Pt2LongRect (pt1: LongPt; pt2: LongPt; var r: LongRect);
  353. function EqualLongRect (r1: LongRect; r2: LongRect): Boolean;
  354. function EmptyLongRect (r: LongRect): Boolean;
  355. function RectInQDSpace (r: LongRect): Boolean;
  356.  
  357.  
  358.  
  359. {****************************************************************************}
  360. { CObject}
  361. {}
  362. {}
  363. {    TCL 1.1 CHANGES}
  364. {    [}
  365. {        - Declare Lock method}
  366. {    ]}
  367. {****************************************************************************}
  368. type
  369. CObject = object
  370.         procedure Free;
  371.         function Clone: CObject;    { TCL 1.1.1 DLP 9/25/91 }
  372.         function Lock (fLock: Boolean): Boolean;
  373.         procedure SubclassResponsibility;
  374.         procedure GetClassName (var className: Str255);
  375.     end;
  376.  
  377. {****************************************************************************}
  378. {    TCLUtilities                                                                             }
  379. {****************************************************************************}
  380.  
  381. function AbortInQueue: Boolean;
  382. function IsCancelEvent (VAR theEvent: EventRecord): Boolean;
  383. procedure ErrorAlert (error: Integer; message: Longint);
  384. function NewHandleCanFail (size: Longint): Handle;
  385. procedure ResizeHandleCanFail (theHandle: univ Handle; newSize: Longint);
  386. function SetAllocation (canFail: Boolean): Boolean;
  387. procedure SetCriticalOperation (aCriticalOp: Boolean);
  388. procedure ForgetHandle (var h: univ Handle);
  389. procedure ForgetObject (var obj: univ CObject);
  390. procedure ForgetPtr (var p: univ Ptr);
  391. procedure ForgetResource (var res: univ Handle);
  392.  
  393. procedure SetMinimumStack (minSize: Longint);
  394.  
  395. function EqualMem (p1, p2: univ Ptr; len: Longint): Boolean;
  396.  
  397. const    { mnemonic constants for SetAllocation flag }
  398.  
  399. kAllocCantFail = FALSE;
  400. kAllocCanFail = TRUE;
  401.  
  402. {****************************************************************************}
  403. { CBartender}
  404. {}
  405. {}
  406. {    TCL 1.1 CHANGES}
  407. {    [}
  408. {        - added EnableMenuBar and DisableMenuBar methods}
  409. {        - added UpdateMenuBar method}
  410. {        - added inMenuBar flag to MenuEntry, to indicate whether the}
  411. {          menu is currently installed in the menu bar.}
  412. {        - added lastEnable flag to MenuEntry, to indicate the last}
  413. {          seen enable state for a menu.}
  414. {        - added forceMBarUpdate instance variable.}
  415. {        - merged CBartender with CBarOwner. CBartender gained a choreAssigned}
  416. {          instance variable.}
  417. {    ]}
  418. {}
  419. {****************************************************************************}
  420.  
  421. type
  422. MenuEntry = record
  423.         MENUid: Integer;
  424.         macMenu: MenuHandle;
  425.         dimming: DimOption;
  426.         numCmds: Integer;
  427.         unchecking: Boolean;
  428.         hasHMenus: Boolean;
  429.         inMenuBar: Boolean;
  430.         lastEnable: Boolean;
  431.         theCommands: LongArrayH;
  432.     end;
  433.  
  434. const
  435.  
  436. xMenuEntries = (maxint div sizeof(MenuEntry)) - 1;        { Used in definition of     }
  437.                                                         { MenuArray type (below)    }
  438. type
  439.  
  440. MenuArrayP = ^MenuArray;
  441. MenuArrayH = ^MenuArrayP;
  442. MenuArray = array[0..xMenuEntries] of MenuEntry;
  443.  
  444. type
  445. CBartender = object(CObject)
  446.         numMenus: Integer;
  447.         theMenus: MenuArrayH;
  448.         choreAssigned: Boolean;
  449.         forceMBarUpdate: Boolean;
  450.         procedure IBartender (MBARid: Integer);
  451.         procedure AddMenu (MENUid: Integer; install: Boolean; beforeID: Integer);
  452.         procedure RemoveMenu (MENUid: Integer);
  453.         procedure InsertInBar (MENUid: Integer; beforeID: Integer);
  454.         procedure DeleteFromBar (MENUid: Integer);
  455.         procedure InsertHierMenu (hMENUid: Integer; cmdNo: Longint; inMENUid: Integer; afterItem: Integer);
  456.         procedure EnableCmd (cmdNo: Longint);
  457.         procedure DisableCmd (cmdNo: Longint);
  458.         procedure EnableMenu (MENUid: Integer);
  459.         procedure DisableMenu (MENUid: Integer);
  460.         procedure EnableMenuBar;
  461.         procedure DisableMenuBar;
  462.         procedure SetCmdText (cmdNo: Longint; theText: Str255);
  463.         procedure GetCmdText (cmdNo: Longint; var theText: Str255);
  464.         procedure CheckMarkCmd (cmdNo: Longint; checked: Boolean);
  465.         procedure InsertMenuCmd (cmdNo: Longint; theText: Str255; MENUid: Integer; afterItem: Integer);
  466.         procedure RemoveMenuCmd (cmdNo: Longint);
  467.         function FindMenuIndex (MENUid: Integer): Integer;
  468.         function FindMacMenu (MENUid: Integer): MenuHandle;
  469.         function FindCmdNumber (MENUid: Integer; itemNo: Integer): Longint;
  470.         procedure FindMenuItem (cmdNo: Longint; var MENUid: Integer; var macMenu: MenuHandle; var itemNo: Integer);
  471.         function FindItemText (MENUid: Integer; itemStr: Str255): Integer;
  472.         procedure ExtractCommands (var theEntry: MenuEntry);
  473.         procedure ParseItemString (var itemStr: Str255; var cmdNo: Longint);
  474.         procedure ExtractHierMenus (macMenu: MenuHandle; index: Integer);
  475.         procedure SetDimOption (MENUid: Integer; aDimming: DimOption);
  476.         procedure SetUnchecking (MENUid: Integer; anUnchecking: Boolean);
  477.         procedure UpdateAllMenus;
  478.         procedure UpdateMenuBar;
  479.     end;
  480.  
  481. {****************************************************************************}
  482. { CAppleEvent}
  483. {****************************************************************************}
  484.  
  485. type
  486. CAppleEvent = object(CObject)
  487.         theEvent: AppleEvent;
  488.         theReply: AppleEvent;
  489.         theRefCon: Longint;
  490.         eventClass: DescType;
  491.         eventID: DescType;
  492.         canInteract: Boolean;
  493.         errCode: Integer;
  494.         notificationRec: NMRecPtr;
  495.         idleProc: Ptr;
  496.  
  497.         procedure IAppleEvent (VAR aeEvent: AppleEvent; VAR aeReply: AppleEvent; aeRefCon: Longint; aeEventClass: DescType; aeEventID: DescType);
  498.         function GetEventClass: DescType;
  499.         function GetEventID: DescType;
  500.         function GetAEEvent: AppleEvent;
  501.         function GetAEReply: AppleEvent;
  502.         function GetAERefCon: Longint;
  503.         procedure GetDescList (whichParam: AEKeyword; var descList: AEDescList);
  504.         function ExtractFromDescList (whichParam: AEKeyword; itemType: DescType; itemSize: Size): CArray;
  505.         function GotRequiredParams: Boolean;
  506.         function RequestInteraction (timeOutTicks: Longint): Integer;
  507.         procedure SetErrorResult (anErrorCode: Integer);
  508.         function GetErrorResult: Integer;
  509.     end;
  510.  
  511. {****************************************************************************}
  512. { CCollaborator}
  513. {****************************************************************************}
  514. type
  515. CCollaborator = object(CObject)
  516.         itsProviders: CList;
  517.         itsDependents: CList;
  518.         procedure ICollaborator;
  519.         procedure DependUpon (aProvider: CCollaborator);
  520.         procedure CancelDependency (aProvider: CCollaborator);
  521.         procedure Free;
  522.         OVERRIDE;
  523.         procedure BroadcastChange (reason: Longint; info: univ Ptr);
  524.         procedure ProviderChanged (aProvider: CCollaborator; reason: Longint; info: univ Ptr);
  525.         procedure AddDependent (aDependent: CCollaborator);
  526.         procedure RemoveDependent (aDependent: CCollaborator);
  527.         procedure AddProvider (aProvider: CCollaborator);
  528.         procedure RemoveProvider (aProvider: CCollaborator);
  529.     end;
  530.  
  531.  
  532. {****************************************************************************}
  533. { CCollection}
  534. {}
  535. {    TCL 1.1 CHANGES}
  536. {    [}
  537. {        - CCollection is now a subclass of CCollaborator}
  538. {    ]}
  539. {}
  540. {****************************************************************************}
  541. type
  542. CCollection = object(CCollaborator)
  543.         numItems: Longint;
  544.         procedure ICollection;
  545.         function GetNumItems: Longint;
  546.         function IsEmpty: Boolean;
  547.     end;
  548.  
  549. {****************************************************************************}
  550. { CArray}
  551. {****************************************************************************}
  552.  
  553. type
  554. CArray = object(CCollection)
  555.         blockSize: Integer; { Number of slots to allocate when }
  556.                              {  more space is needed            }
  557.  
  558.         slots: Longint;     { Total number of slots allocated    }
  559.         hItems: Handle;    { Items in the array                }
  560.         elementSize: Longint; { size of each element in bytes    }
  561.         lockChanges: Boolean; { can't insert or delete if locked }
  562.         usingTemporary: Boolean; { TRUE if temporary element storage}
  563.                                   { buffer is in use                  }
  564.  
  565.         procedure IArray (anElementSize: Longint);
  566.         procedure Free;
  567.         OVERRIDE;
  568.         procedure SetBlockSize (aBlockSize: Integer);
  569.         procedure InsertAtIndex (itemPtr: univ Ptr; index: Longint);
  570.         procedure DeleteItem (index: Longint);
  571.         procedure MoveItemToIndex (currentIndex: Longint; newIndex: Longint);
  572.         procedure SetItem (itemPtr: univ Ptr; index: Longint);
  573.         procedure GetItem (itemPtr: univ Ptr; index: Longint);
  574.         procedure Swap (index1: Longint; index2: Longint);
  575.         function Search (itemPtr: univ Ptr; function compare (item1, item2: univ Ptr): Boolean): Longint;
  576.         function SetLockChanges (fLockChanges: Boolean): Boolean;
  577.         procedure Resize (numSlots: Longint);
  578.         procedure MoreSlots;
  579.  
  580.         procedure CopyToTemporary (index: Longint);
  581.         procedure CopyFromTemporary (index: Longint);
  582.         function ItemOffset (itemIndex: Longint): Longint;
  583.  
  584.         { PRIVATE }
  585.  
  586.         procedure AssertIndex (index: Longint);
  587.         function GetItemPtr (index: Longint): Ptr;
  588.         procedure Store (itemPtr: univ Ptr; index: Longint);
  589.         procedure Retrieve (itemPtr: univ Ptr; index: Longint);
  590.         function Clone: CObject; { TCL 1.1.1 DLP 9/25/91 }
  591.         OVERRIDE;
  592.     end;
  593.  
  594. {     A pointer to a tMovedElementInfo structure is passed as the info    }
  595. {     parameter to BroadCastChange when MoveItemToIndex has completed    }
  596.  
  597. type
  598. tMovedElementInfo = record
  599.         originalIndex: Longint; { item's original index    }
  600.         newIndex: Longint;          { item's new index            }
  601.     end;
  602. tMovedElementInfoPtr = ^tMovedElementInfo;
  603.  
  604.  
  605. { Change protocol for Array class }
  606.  
  607. const                                { index of new element        }
  608.  
  609. arrayInsertElement = 1;                { index of new element        }
  610. arrayDeleteElement = 2;                { index of deleted element    }
  611. arrayMoveElement = 3;                { pointer to tMovedElementInfo, see above }
  612. arrayElementChanged = 4;            { index of changed element    }
  613.  
  614. arrayLastChange = arrayElementChanged;
  615.  
  616. BAD_INDEX = -1;                { Flag indicating a failed search    }
  617.  
  618. {****************************************************************************}
  619. { CRunArray}
  620. {}
  621. {****************************************************************************}
  622.  
  623. { structure used to store run info    }
  624. type
  625. tRun = record
  626.         runLength: Longint;    { number of consecutive entries with same value    }
  627.         value: Longint;        { the value                                        }
  628.     end;
  629.  
  630. const
  631. xRuns = (maxint div sizeof(tRun)) - 1;
  632.  
  633. type
  634.  
  635. tRunArray = array[0..xRuns] of tRun;
  636. tRunPtr = ^tRunArray;
  637. tRunHndl = ^tRunPtr;
  638.  
  639. type
  640. CRunArray = object(CArray)
  641.  
  642.         itemCount: Longint;    { number of values in array - numItems is number of runs    }
  643.         hRuns: tRunHndl;    { handle to runs, same as CArray.hItems                    }
  644.  
  645.         procedure IRunArray;
  646.         procedure InsertValue (item, value, count: Longint);
  647.         procedure SetValue (index, value: Longint);
  648.         function GetValue (index: Longint): Longint;
  649.         procedure DeleteValue (index: Longint);
  650.         procedure DeleteAll;
  651.         function SumRange (startIndex, endIndex: Longint): Longint;
  652.         function FindSum (aSum: Longint): Longint;
  653.         function GetNumItems: Longint;
  654.         OVERRIDE;
  655.         procedure FindRun (itemIndex: Longint; var runIndex, firstInRun: Longint);
  656.         procedure InsertRun (index, runLength, value: Longint);
  657.         procedure DeleteRun (runIndex: Longint);
  658.         function Clone: CObject; { TCL 1.1.1 DLP 9/25/91 }
  659.         OVERRIDE;
  660.     end;
  661.  
  662. { change protocol    }
  663.     {)
  664. {     *    CRunArray will send its dependents the runArraySizeChanged}
  665. {     *  change message when InsertValue, DeleteValue, or DeleteAll}
  666. {     *  methods are called. Since it is a subclass of CArray, it }
  667. {     *  may also send CArray change messages, but those signal}
  668. {     *  changes in the runs, not in the elements themselves, and}
  669. {     *  will not usually be of interest to dependents.}
  670. {     }
  671.  
  672. const                        { info parameter is pointer to new size    }
  673.  
  674. runArraySizeChanged = arrayLastChange + 1;
  675.  
  676. runArrayLastChange = runArraySizeChanged;
  677.  
  678.  
  679. {****************************************************************************}
  680. { CCluster}
  681. {}
  682. {    TCL 1.1 CHANGES}
  683. {    [}
  684. {        - CCluster is now a subclass of CArray. CArray already has}
  685. {          the instance variables blockSize and slots,  so}
  686. {          these are removed from CCluster's declaration. CArray also}
  687. {          has an items handle, but it is declared as a handle instead}
  688. {          of LongHandle. For backward compatibility, the items instance}
  689. {          variable is maintained, but as an alias to CArray's handle.}
  690. {          This also lets certain operations be implemented more efficiently.}
  691. {        - The Free, MoreSlots, and SetBlockSize methods have been}
  692. {          removed because they are now implemented by CArray.}
  693. {        - moved BAD_INDEX constant to CArray}
  694. {        - override of Clone}
  695. {    ]}
  696. {}
  697. {****************************************************************************}
  698.  
  699. const
  700.  
  701. SLOT_SIZE = 4;        { Size of an item in a cluster    }
  702.  
  703. type
  704.  
  705. ObjArrayP = ^ObjArray;
  706. ObjArrayH = ^ObjArrayP;
  707. ObjArray = array[0..xLongs] of CObject;
  708.  
  709. CCluster = object(CArray)
  710.         items: ObjArrayH;
  711.         procedure ICluster;
  712.         procedure DisposeAll;
  713.         procedure DisposeItems;
  714.         procedure Add (theObject: CObject);
  715.         procedure Remove (theObject: CObject);
  716.         function Includes (theObject: CObject): Boolean;
  717.         procedure DoForEach (procedure proc (theObject: CObject));
  718.         procedure DoForEach1 (procedure proc (theObject: CObject; theParam: univ Ptr); param: univ Ptr);
  719.         function FindItem (function testFunc (theObject: CObject): Boolean): CObject;
  720.         function FindItem1 (function testFunc (theObject: CObject; theParam: univ Ptr): Boolean; param: univ Ptr): CObject;
  721.         function Offset (theObject: CObject): Longint;
  722.         function Clone: CObject; { TCL 1.1.1 DLP 9/25/91 }
  723.         OVERRIDE;
  724.     end;
  725.  
  726.  
  727. {****************************************************************************}
  728. { CList}
  729. {}
  730. {    TCL 1.1 CHANGES}
  731. {    [}
  732. {        - CList is now a subclass of CArray (via CCluster).}
  733. {        - The Remove method was removed because it is already implemented}
  734. {          in CCluster}
  735. {    ]}
  736. {}
  737. {****************************************************************************}
  738. type
  739.  
  740. CList = object(CCluster)
  741.  
  742.                                 { Instance Methods }
  743.  
  744.         procedure IList;
  745.         procedure Append (theObject: CObject);
  746.         procedure Prepend (theObject: CObject);
  747.         procedure InsertAfter (theObject: CObject; afterObject: CObject);
  748.         procedure InsertAt (theObject: CObject; index: longint);
  749.         procedure BringFront (theObject: CObject);
  750.         procedure SendBack (theObject: CObject);
  751.         procedure MoveUp (theObject: CObject);
  752.         procedure MoveDown (theObject: CObject);
  753.         procedure MoveToIndex (theObject: CObject; index: longint);
  754.         function FirstItem: CObject;
  755.         function LastItem: CObject;
  756.         function NthItem (n: longint): CObject;
  757.         function FindIndex (theObject: CObject): longint;
  758.         function FirstSuccess (function testFunc (theObject: CObject): boolean): CObject;
  759.         function FirstSuccess1 (function testFunc (theObject: CObject; theParam: univ Ptr): boolean; param: univ Ptr): CObject;
  760.         function LastSuccess (function testFunc (theObject: CObject): boolean): CObject;
  761.         function LastSuccess1 (function testFunc (theObject: CObject; theParam: univ Ptr): boolean; param: univ Ptr): CObject;
  762.     end;
  763.  
  764. { Change protocol for List class                                         }
  765. { This is just a redeclaration of the same protocol as CArray            }
  766. { redefined as "list" constants because lists are used so frequently    }
  767. { reason parameter                                                     }
  768.  
  769. const                                { index of new element        }
  770.  
  771. listInsertElement = 1;                { index of new element        }
  772. listDeleteElement = 2;                { index of deleted element    }
  773. listMoveElement = 3;                { pointer to tMovedElementInfo, see above }
  774. listElementChanged = 4;                { index of changed element    }
  775.  
  776. listLastChange = listElementChanged;
  777.  
  778. {****************************************************************************}
  779. { CChore}
  780. {}
  781. {****************************************************************************}
  782. type
  783. CChore = object(CObject)
  784.  
  785.         procedure Perform (var maxSleep: Longint);
  786.     end;
  787.  
  788. {****************************************************************************}
  789. { CMBarChore}
  790. {}
  791. {****************************************************************************}
  792. type
  793. CMBarChore = object(CChore)
  794.  
  795.         procedure Perform (var maxSleep: Longint);
  796.         OVERRIDE;
  797.     end;
  798.  
  799. {****************************************************************************}
  800. { CEnvironment}
  801. {}
  802. {****************************************************************************}
  803.  
  804. type
  805. CEnvironment = object(CObject)
  806.         procedure Restore;
  807.     end;
  808.  
  809.  
  810. {****************************************************************************}
  811. { CError}
  812. {}
  813. {****************************************************************************}
  814. type
  815. CError = object(CObject)
  816.         procedure SevereMacError (macErr: Integer);
  817.         function CheckOSError (macErr: Integer): Boolean;
  818.         procedure PostAlert (STRid: Integer; index: Integer);
  819.         procedure MissingResources;
  820.     end;
  821.  
  822.  
  823.  
  824. {****************************************************************************}
  825. { CDecorator}
  826. {}
  827. {    TCL 1.1 CHANGES}
  828. {    [}
  829. {        - added StaggerWindow method}
  830. {    ]}
  831. {}
  832. {****************************************************************************}
  833. type
  834. CDecorator = object(CObject)
  835.         wCount: Integer;
  836.         index: Integer;
  837.         wWidth: Integer;
  838.         wHeight: Integer;
  839.         hLocation: Integer;
  840.         vLocation: Integer;
  841.         procedure IDecorator;
  842.         procedure PlaceNewWindow (theWindow: CWindow);
  843.         procedure StaggerWindow (theWindow: CWindow);
  844.         procedure CenterWindow (theWindow: CWindow);
  845.         function GetWCount: Integer;
  846.     end;
  847.  
  848. {****************************************************************************}
  849. { CPrinter}
  850. {}
  851. {}
  852. {    TCL 1.1 CHANGES}
  853. {    [}
  854. {        - added printMgrOpen, printDocOpen, printPageOpen, savedResFile,}
  855. {          printDirection instance variables}
  856. {        - changed interface for OpenPrintMgr}
  857. {        - added ClosePrintMgr, SetPrintDir, HavePagination, ResetPagination,}
  858. {          SetStrips, SetHorizPageBreak, SetVertPageBreak, SetAllStripWidths,}
  859. {          SetStripHeight, SetAllStripHeights, GetStripCount, PageNumToStrips,}
  860. {          GetPageStart, GetPageArea methods}
  861. {    ] }
  862. {}
  863. {****************************************************************************}
  864.  
  865. const
  866. kUsePaperWidth = -1;
  867. kUsePaperHeight = -1;
  868.  
  869. type
  870.  
  871. tPrintDirection = (
  872.  
  873.     printHoriz,        { printing proceeds row by row         }
  874.     printVert        { printing proceeds column by column     }
  875.  
  876.     );
  877.  
  878.  
  879. CPrinter = object(CObject)
  880.         itsDocument: CDocument;
  881.         macTPrint: Handle;
  882.         macPrintPort: GrafPtr;
  883.         printDirection: tPrintDirection;
  884.         printMgrOpen: Boolean;
  885.         printDocOpen: Boolean;
  886.         printPageOpen: Boolean;
  887.         savedResFile: Integer;
  888.         itsStripWidths: CRunArray;
  889.         itsStripHeights: CRunArray;
  890.         function IPrinter (aDocument: CDocument; aMacTPrint: Handle): Boolean;
  891.         procedure Free;
  892.         OVERRIDE;
  893.         function OpenPrintMgr (fCheckFailure: Boolean): Boolean;
  894.         procedure ClosePrintMgr;
  895.         function GetPrintRecord: Handle;
  896.         procedure GetPageInfo (var paperRect: Rect; var pageRect: Rect; var hRes: Integer; var vRes: Integer);
  897.         function DoPageSetup: Boolean;
  898.         procedure SetPrintDir (aPrintDir: tPrintDirection);
  899.         function HavePagination: Boolean;
  900.         procedure ResetPagination;
  901.         procedure SetStrips (numHStrips, numVStrips: Integer);
  902.         procedure SetHorizPageBreak (vStripNum: Integer; hPos: Longint);
  903.         procedure SetVertPageBreak (hStripNum: Integer; vPos: Longint);
  904.         procedure SetAllStripWidths (aStripWidth: Integer);
  905.         procedure SetStripWidth (pageNum: Integer; aStripWidth: Integer);
  906.         procedure SetAllStripHeights (aStripHeight: Integer);
  907.         procedure SetStripHeight (pageNum: Integer; aStripHeight: Integer);
  908.         procedure GetStripCount (var hStrips: Integer; var vStrips: Integer);
  909.         procedure PageNumToStrips (pageNum: Integer; var hStrip: Integer; var vStrip: Integer);
  910.         procedure GetPageStart (pageNum: Integer; var startPos: LongPt);
  911.         procedure GetPageArea (pageNum: Integer; var pageArea: LongRect);
  912.         procedure DoPrint;
  913.         procedure PrintPageRange (firstPage: Integer; lastPage: Integer);
  914.     end;
  915.  
  916. {****************************************************************************}
  917. { CPaneBorder}
  918. {}
  919. {****************************************************************************}
  920.  
  921. const
  922.  
  923. kBorderNone = $00;
  924. kBorderLeft = $01;
  925. kBorderTop = $02;
  926. kBorderRight = $04;
  927. kBorderBottom = $08;
  928. kBorderFrame = kBorderLeft + kBorderTop + kBorderRight + kBorderBottom;
  929. kBorderOval = $10;
  930. kBorderRoundRect = $20;
  931. kBorderRsrv1 = $40;
  932. kBorderRsrv2 = $80;
  933.  
  934. kPaneBorderRes = 'PBrd';     { CPaneBorder resource type }
  935.  
  936.  
  937. type
  938. CPaneBorder = object(CObject)
  939.         borderFlags: Longint;    { describes the type of border                    }
  940.         borderPen: Point;        { pen size for border                            }
  941.         shadowOffset: Point;    { amount to offset for shadow                    }
  942.         shadowPen: Point;        { pen size for shadow                            }
  943.         doShadow: Boolean;        { TRUE if shadow is drawn                        }
  944.         roundDiameter: Point;    { oval width and height for rounded rectangle    }
  945.         penPattern: Pattern;        { pattern for border                            }
  946.         margin: Rect;            { minimum whitespace desired                    }
  947.  
  948.         procedure IPaneBorder (aBorderFlags: Longint);
  949.         procedure IResPaneBorder (resID: Integer);
  950.         procedure SetPattern (aPattern: Pattern);
  951.         procedure GetPattern (var aPattern: Pattern);
  952.         procedure SetBorderFlags (aBorderFlags: Longint);
  953.         function GetBorderFlags: Longint;
  954.         procedure SetPenSize (penWidth: Integer; penHeight: Integer);
  955.         procedure GetPenSize (var penWidth: Integer; var penHeight: Integer);
  956.         procedure SetShadow (hOffset: Integer; vOffset: Integer; width: Integer; height: Integer);
  957.         procedure GetShadow (var hOffset: Integer; var vOffset: Integer; var width: Integer; var height: Integer);
  958.         procedure SetRounding (hDiameter: Integer; vDiameter: Integer);
  959.         procedure GetRounding (var hDiameter: Integer; var vDiameter: Integer);
  960.         procedure SetMargin (aMargin: Rect);
  961.         procedure GetMargin (var aMargin: Rect);
  962.         procedure CalcBorderRect (var paneFrame: Rect);
  963.         procedure DrawBorder (paneFrame: Rect);
  964.     end;
  965.  
  966.                 { CPaneBorder resource template }
  967. PaneBorderTemp = record
  968.         borderFlags: Longint;
  969.         borderPen: Point;
  970.         shadowOffset: Point;
  971.         shadowPen: Point;
  972.         roundDiameter: Point;
  973.         patID: Integer;
  974.         margin: Rect;
  975.     end;
  976. PaneBorderTempPtr = ^PaneBorderTemp;
  977. PaneBorderTempHndl = ^PaneBorderTempPtr;
  978.  
  979.  
  980. {****************************************************************************}
  981. { CSwitchboard}
  982. {        }
  983. {    TCL 1.1 CHANGES}
  984. {    [}
  985. {        - added GetAnEvent, DispatchEvent, DoHighLevelEvent, DoAppleEvent methods}
  986. {    ]}
  987. {}
  988. {****************************************************************************}
  989. type
  990. CSwitchboard = object(CObject)
  991.         mouseRgn: RgnHandle;
  992.         procedure ISwitchboard;
  993.         procedure DoMouseDown (VAR macEvent: EventRecord);
  994.         procedure DoMouseUp (VAR macEvent: EventRecord);
  995.         procedure DoKeyEvent (VAR macEvent: EventRecord);
  996.         procedure DoDiskEvent (VAR macEvent: EventRecord);
  997.         procedure DoUpdate (VAR macEvent: EventRecord);
  998.         procedure DoActivate (VAR macEvent: EventRecord);
  999.         procedure DoDeactivate (VAR macEvent: EventRecord);
  1000.         procedure DoSuspend (VAR macEvent: EventRecord);
  1001.         procedure DoResume (VAR macEvent: EventRecord);
  1002.         procedure DoOtherEvent (VAR macEvent: EventRecord);
  1003.         procedure DoIdle (VAR macEvent: EventRecord);
  1004.         procedure ProcessEvent;
  1005.         function GetAnEvent (var macEvent: EventRecord): Boolean;
  1006.         procedure DispatchEvent (VAR macEvent: EventRecord);
  1007.         procedure DoHighLevelEvent (VAR macEvent: EventRecord);
  1008.         function DoAppleEvent (VAR theEvent: AppleEvent; VAR theReply: AppleEvent; refCon: Longint): Integer;
  1009.         function AppleEventIdle (VAR macEvent: EventRecord; sleepTime: Longint; mouseRgn: RgnHandle): Boolean;
  1010.     end;
  1011.  
  1012. {****************************************************************************}
  1013. { CTask}
  1014. {}
  1015. {    TCL 1.1 CHANGES}
  1016. {    [}
  1017. {        - added undone instance variable and IsUndone method.}
  1018. {    ]}
  1019. {}
  1020. {****************************************************************************}
  1021.  
  1022. type
  1023. CTask = object(CObject)
  1024.         nameIndex: Integer;    { Index for name in string list    }
  1025.         undone: Boolean;
  1026.         procedure ITask (aNameIndex: Integer);
  1027.         function GetNameIndex: Integer;
  1028.         procedure DoTask;
  1029.         procedure Undo;
  1030.         procedure Redo;
  1031.         function IsUndone: Boolean;
  1032.     end;
  1033.  
  1034. {****************************************************************************}
  1035. { CMouseTask}
  1036. {****************************************************************************}
  1037. type
  1038. CMouseTask = object(CTask)
  1039.         procedure IMouseTask (aNameIndex: Integer);
  1040.         procedure BeginTracking (var startPt: LongPt);
  1041.         procedure KeepTracking (var currPt, prevPt, startPt: LongPt);
  1042.         procedure EndTracking (var currPt, prevPt, startPt: LongPt);
  1043.     end;
  1044.  
  1045. {****************************************************************************}
  1046. { CBureaucrat}
  1047. {}
  1048. {    TCL 1.1 CHANGES}
  1049. {    [}
  1050. {        - added BecomeGopher method}
  1051. {        - changed superclass to CCollaborator}
  1052. {        - added override of BroadcastChange, ProviderChanged}
  1053. {        - added DoAppleEvent method}
  1054. {    ]}
  1055. {}
  1056. {****************************************************************************}
  1057. type
  1058. CBureaucrat = object(CCollaborator)
  1059.  
  1060.         itsSupervisor: CBureaucrat;
  1061.  
  1062.         procedure IBureaucrat (aSupervisor: CBureaucrat);
  1063.         procedure Free;
  1064.         OVERRIDE;
  1065.         function GetSupervisor: CBureaucrat;
  1066.         procedure Notify (theTask: CTask);
  1067.         procedure DoKeyDown (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1068.         procedure DoAutoKey (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1069.         procedure DoKeyUp (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1070.         procedure DoCommand (theCommand: Longint);
  1071.         procedure Dawdle (var maxSleep: Longint);
  1072.         procedure UpdateMenus;
  1073.         function BecomeGopher (fBecoming: Boolean): Boolean;
  1074.         procedure BroadcastChange (reason: Longint; info: univ Ptr);
  1075.         OVERRIDE;
  1076.         procedure ProviderChanged (aProvider: CCollaborator; reason: Longint; info: univ Ptr);
  1077.         OVERRIDE;
  1078.         procedure DoAppleEvent (anAppleEvent: CAppleEvent);
  1079.     end;
  1080.  
  1081. { Change propagation constants for CBureacrat }
  1082.  
  1083. const
  1084.  
  1085.             { bureaucrat has become the gopher, info parameter is zero }
  1086. bureaucratIsGopher = 1;
  1087.  
  1088.             { bureaucrat is no longer the gopher, info parameter is zero }
  1089. bureaucratIsNotGopher = 2;
  1090.  
  1091. bureaucratLastChange = bureaucratIsNotGopher;
  1092.  
  1093. {****************************************************************************}
  1094. { CDirectorOwner}
  1095. {}
  1096. {        Interface for CDirectorOwner class}
  1097. {}
  1098. {    SUPERCLASS = CBureacrat}
  1099. {}
  1100. {    Copyright © 1991 Symantec Corporation. All rights reserved.}
  1101. {}
  1102. {}
  1103. {****************************************************************************}
  1104.  
  1105.  
  1106. type
  1107. CDirectorOwner = object(CBureaucrat)
  1108.  
  1109.         itsDirectors: CList;    { list of its directors}
  1110.         active: Boolean;        { TRUE if any director is active}
  1111.  
  1112.         procedure IDirectorOwner (aSupervisor: CDirectorOwner);
  1113.         procedure AddDirector (aDirector: CDirector);
  1114.         procedure RemoveDirector (aDirector: CDirector);
  1115.         procedure ActivateDirector (aDirector: CDirector);
  1116.         procedure DeactivateDirector (aDirector: CDirector);
  1117.         procedure Suspend;
  1118.         procedure Resume;
  1119.         function Quit: Boolean;
  1120.         function Close (quitting: Boolean): Boolean;
  1121.         procedure Free;
  1122.         OVERRIDE;
  1123.     end;
  1124.  
  1125. {****************************************************************************}
  1126. { CApplication}
  1127. {}
  1128. {    TCL 1.1 CHANGES}
  1129. {    [}
  1130. {        - added MakeSwitchBoard, MakeBartender, and MakeError methods}
  1131. {        - removed eventLoopJump instance variable}
  1132. {        - added Process1Event, PackageAppleEvent, DoAppleEvent method}
  1133. {        - added phase instance variable, phase enumeration constants,}
  1134. {          and GetPhase methods. The application is always in one of three}
  1135. {          phases: initializing, running, or quitting.}
  1136. {        - added class variable cMaxSleepTime, which determines the default}
  1137. {          maximum sleep time passed to WaitNextEvent}
  1138. {        - changed interface for IApplication, InitMemory, and RequestMemory methods}
  1139. {        - added SetCriticalOperation method}
  1140. {        - removed instance variables loanApproved and creditLimit}
  1141. {        - added instance variables criticalBalance, toolboxBalance,}
  1142. {          and tempAllocation.}
  1143. {        - added methods InstallPatches, RemovePatches, ForceClassReferences}
  1144. {    ]}
  1145. {}
  1146. {****************************************************************************}
  1147.  
  1148. const
  1149.     { phases of application execution, return by GetPhase() method }
  1150.  
  1151. appInitializing = 1;
  1152. appRunning = 2;
  1153. appQuitting = 3;
  1154.  
  1155. GROW_FAILURE = 0;
  1156. GROW_SUCCESS = 1;
  1157.  
  1158. type
  1159. CApplication = object(CDirectorOwner)
  1160.  
  1161.         itsSwitchboard: CSwitchboard;      { Retrieves and processes events    }
  1162.         itsIdleChores: CList;            { Chores to perform at idle time    }
  1163.         itsUrgentChores: CCluster;        { Chores to perform ASAP            }
  1164.         urgentsToDo: Boolean;            { Are any urgent chores pending?    }
  1165.         running: Boolean;                { Status flag                        }
  1166.         phase: Integer;                    { what phase is the application in? }
  1167.         rainyDayFund: Longint;            { Bytes of memory to set aside        }
  1168.         criticalBalance: Longint;        { bytes to save for critical operations }
  1169.         toolboxBalance: Longint;        { bytes to save for the toolbox    }
  1170.         tempAllocation: Longint;        { bytes of temporarily allocate mem }
  1171.         rainyDay: Handle;                { Handle to the reserve memory        }
  1172.         rainyDayUsed: Boolean;            { Has rainy day fund been tapped?    }
  1173.         memWarningIssued: Boolean;        { Has user been alerted?            }
  1174.         canFail: Boolean;                { OK for memory request to fail?    }
  1175.         inCriticalOperation: Boolean;    { OK to use critical memory reserve? }
  1176.         sfNumTypes: Integer;            { Number of file types recognized    }
  1177.         sfFileTypes: SFTypeList;        { File types which are recognized    }
  1178.         sfFileFilter: FileFilterUPP;     { Filter for files to display        }
  1179.         sfGetDLOGHook: DlgHookUPP;        { Hook for handling get dialog        }
  1180.         sfGetDLOGid: Integer;            { Dialog resource ID for get file    }
  1181.         sfGetDLOGFilter: ModalFilterUPP; { Filter for get dialog events        }
  1182.         unhandledTask: CTask;            { Task that no document handled    }
  1183.  
  1184.         procedure IApplication (extraMasters: Integer; aRainyDayFund: Longint; aCriticalBalance: Longint; aToolboxBalance: Longint);
  1185.         procedure InitToolbox;
  1186.         procedure InitMemory (extraMasters: Integer; aRainyDayFund: Longint; aCriticalBalance: Longint; aToolboxBalance: Longint);
  1187.         procedure InstallPatches;
  1188.         procedure RemovePatches;
  1189.         procedure InspectSystem;
  1190.         procedure MakeDesktop;
  1191.         procedure MakeClipboard;
  1192.         procedure MakeDecorator;
  1193.         procedure MakeSwitchboard;
  1194.         procedure MakeBartender;
  1195.         procedure MakeError;
  1196.         procedure SetUpFileParameters;
  1197.         procedure SetUpMenus;
  1198.         procedure ForceClassReferences;
  1199.         procedure Notify (theTask: CTask);
  1200.         OVERRIDE;
  1201.         procedure DoKeyDown (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1202.         OVERRIDE;
  1203.         procedure DoAutoKey (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1204.         OVERRIDE;
  1205.         procedure DoKeyUp (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  1206.         OVERRIDE;
  1207.         procedure DoCommand (theCommand: Longint);
  1208.         OVERRIDE;
  1209.         procedure UpdateMenus;
  1210.         OVERRIDE;
  1211.         function PackageAppleEvent (VAR theEvent: AppleEvent; VAR theReply: AppleEvent; theRefCon: Longint; eventClass: DescType; eventID: DescType): CAppleEvent;
  1212.         procedure DoAppleEvent (anAppleEvent: CAppleEvent);
  1213.         OVERRIDE;
  1214.         procedure RequestMemory (aCanFail: Boolean);
  1215.         procedure SetCriticalOperation (fInCriticalOperation: Boolean);
  1216.         function GrowMemory (bytesNeeded: Longint): Longint;
  1217.         procedure MemoryShortage (bytesNeeded: Longint);
  1218.         procedure MemoryReplenished;
  1219.         function OutOfMemory (bytesNeeded: Longint): Longint;
  1220.         procedure Run;
  1221.         procedure Process1Event;
  1222.         procedure Preload;
  1223.         procedure StartUpAction (numPreloads: Integer);
  1224.         procedure Suspend;
  1225.         OVERRIDE;
  1226.         procedure Resume;
  1227.         OVERRIDE;
  1228.         procedure SwitchToDA;
  1229.         procedure SwitchFromDA;
  1230.         procedure Idle (VAR macEvent: EventRecord);
  1231.         function Quit: Boolean;
  1232.         OVERRIDE;
  1233.         procedure ExitApp;
  1234.         procedure JumpToEventLoop;
  1235.         function GetPhase: Integer;
  1236.         procedure CreateDocument;
  1237.         procedure OpenDocument (macSFReply: SFReply);
  1238.         procedure DoOpenOrPrintDocEvent (theEvent: CAppleEvent);
  1239.         procedure ChooseFile (var macSFReply: SFReply);
  1240.         procedure AssignIdleChore (theChore: CChore);
  1241.         procedure CancelIdleChore (theChore: CChore);
  1242.         procedure AssignUrgentChore (theChore: CChore);
  1243.     end;
  1244.  
  1245.     { utility routines defined for the benefit of the Exceptions library }
  1246.  
  1247. procedure ExitApplication;
  1248. function ApplicationIsRunning: Boolean;
  1249.  
  1250. var
  1251. cMaxSleepTime: Longint;
  1252.  
  1253. {****************************************************************************}
  1254. { CDirector}
  1255. {}
  1256. {    TCL 1.1 CHANGES}
  1257. {    [}
  1258. {        - added GetWindow, FindViewByID methods}
  1259. {        - added override of ProviderChanged}
  1260. {        - added activateWindOnResume instance variable}
  1261. {    ]}
  1262. {}
  1263. {****************************************************************************}
  1264. type
  1265. CDirector = object(CDirectorOwner)
  1266.  
  1267.         itsWindow: CWindow;
  1268.         itsGopher: CBureaucrat;
  1269.         activateWindOnResume: Boolean;
  1270.                                         { TCL 1.1.1 DLP 9/25/91 }
  1271.         alreadyClosing: Boolean;        { TRUE while attempting to Close    }
  1272.                                         { the director                        }
  1273.  
  1274.  
  1275.         procedure IDirector (aSupervisor: CDirectorOwner);
  1276.         procedure Free;
  1277.         OVERRIDE;
  1278.         procedure DoCommand (theCommand: Longint);
  1279.         OVERRIDE;
  1280.         procedure UpdateMenus;
  1281.         OVERRIDE;
  1282.         procedure Activate;
  1283.         procedure Deactivate;
  1284.         procedure Suspend;
  1285.         OVERRIDE;
  1286.         procedure Resume;
  1287.         OVERRIDE;
  1288.         function Close (quitting: Boolean): Boolean;
  1289.         OVERRIDE;
  1290.         procedure CloseWind (theWindow: CWindow);
  1291.         procedure ActivateWind (theWindow: CWindow);
  1292.         procedure DeactivateWind (theWindow: CWindow);
  1293.         function IsActive: Boolean;
  1294.         procedure ActivateDirector (aDirector: CDirector);
  1295.         OVERRIDE;
  1296.         procedure DeactivateDirector (aDirector: CDirector);
  1297.         OVERRIDE;
  1298.         function OwnsWindow (aWindow: CWindow): Boolean;
  1299.         function GetWindow: CWindow;
  1300.         function FindViewByID (aViewID: Longint): CView;
  1301.         procedure ProviderChanged (aProvider: CCollaborator; reason: Longint; info: univ Ptr);
  1302.         OVERRIDE;
  1303.         procedure RemoveDirector (aDirector: CDirector);
  1304.         OVERRIDE;
  1305.     end;
  1306.  
  1307. { symbolic constants for Boolean parameters}
  1308.  
  1309. const
  1310. kNotQuitting = FALSE;
  1311. kQuitting = TRUE;
  1312.  
  1313.  
  1314. {****************************************************************************}
  1315. { CDocument}
  1316. {}
  1317. {    TCL 1.1 CHANGES}
  1318. {    [}
  1319. {        - added MakePrinter, DoAppleEvent method}
  1320. {    ]}
  1321. {}
  1322. {****************************************************************************}
  1323. type
  1324. CDocument = object(CDirector)
  1325.  
  1326.         itsMainPane: CPane;
  1327.         itsFile: CFile;
  1328.         lastTask: CTask;
  1329.         undone: Boolean;
  1330.         itsPrinter: CPrinter;
  1331.         dirty: Boolean;
  1332.         pageWidth: Integer;
  1333.         pageHeight: Integer;
  1334.  
  1335.         procedure IDocument (aSupervisor: CApplication; printable: Boolean);
  1336.         procedure Free;
  1337.         OVERRIDE;
  1338.         procedure Notify (theTask: CTask);
  1339.         OVERRIDE;
  1340.         procedure DoCommand (theCommand: Longint);
  1341.         OVERRIDE;
  1342.         procedure UpdateMenus;
  1343.         OVERRIDE;
  1344.         function Close (quitting: Boolean): Boolean;
  1345.         OVERRIDE;
  1346.         procedure CloseWind (theWindow: CWindow);
  1347.         OVERRIDE;
  1348.         function ConfirmClose (quitting: Boolean): Boolean;
  1349.         procedure NewFile;
  1350.         procedure OpenFile (macSFReply: SFReply);
  1351.         procedure MakePrinter;
  1352.         procedure Paginate;
  1353.         function PageCount: Integer;
  1354.         procedure AboutToPrint (var firstPage: Integer; var lastPage: Integer);
  1355.         procedure PrintPageOfDoc (pageNum: Integer);
  1356.         procedure DonePrinting;
  1357.         function DoSave: Boolean;
  1358.         function DoSaveAs (macSFReply: SFReply): Boolean;
  1359.         procedure DoRevert;
  1360.         function DoSaveFileAs: Boolean;
  1361.         procedure PickFileName (var macSFReply: SFReply);
  1362.         procedure GetName (var theName: Str255);
  1363.         procedure UpdateUndo;
  1364.     end;
  1365.  
  1366. { symbolic constants for Boolean parameters}
  1367.  
  1368. const
  1369. kNotPrintable = FALSE;
  1370. kPrintable = TRUE;
  1371.  
  1372.  
  1373. {****************************************************************************}
  1374. { CClipboard}
  1375. {        }
  1376. {    TCL 1.1 CHANGES}
  1377. {    [}
  1378. {        - added EmptyGlobalScrap, EmptyScrap methods. PutGlobalScrap}
  1379. {          no longer calls ZeroScrap, so you must call EmptyGlobalScrap}
  1380. {          or EmptyScrap before calling PutGlobalScrap or PutData.}
  1381. {        - added MakeClipView method}
  1382. {    ]}
  1383. {}
  1384. {****************************************************************************}
  1385.  
  1386.  
  1387. type
  1388.  
  1389. ScrapStatus = (GLOBAL_SCRAP_NEWER, PRIVATE_SCRAP_NEWER, SCRAPS_THE_SAME);
  1390.  
  1391. CClipboard = object(CDirector)
  1392.  
  1393.                     { Instance Variables }
  1394.  
  1395.         itsContents: CPanorama;            { Pane for displaying contents        }
  1396.         itsScrollPane: CScrollPane;        { Contents can be scrolled             }
  1397.         theLength: longint;                { Length from last Get operation    }
  1398.         theOffset: longint;                { Offset from last Get operation    }
  1399.         lastScrapCount: integer;        { Count at the last conversion        }
  1400.                                         {   between global and private        }
  1401.  
  1402.         privateNewer: Boolean;            { Has private scrap changed since    }
  1403.                                         {   last conversion?                }
  1404.  
  1405.         windowVisible: Boolean;            { Is clipboard window visible?        }
  1406.  
  1407.                         { Instance Methods }
  1408.  
  1409.         procedure IClipboard (aSupervisor: CApplication; hasWindow: Boolean);
  1410.         procedure Suspend;
  1411.         OVERRIDE;
  1412.         procedure Resume;
  1413.         OVERRIDE;
  1414.         function Close (quitting: Boolean): Boolean;
  1415.         OVERRIDE;
  1416.         procedure CloseWind (theWindow: CWindow);
  1417.         OVERRIDE;
  1418.         procedure Toggle;
  1419.         procedure PutGlobalScrap (theType: ResType; theData: Handle);
  1420.         function GetGlobalScrap (theType: ResType; theData: Handle): Boolean;
  1421.         function Status: ScrapStatus;
  1422.         procedure ScrapConverted;
  1423.         procedure ConvertGlobal;
  1424.         procedure ConvertPrivate;
  1425.         procedure EmptyGlobalScrap;
  1426.         procedure EmptyScrap;
  1427.         procedure PutData (theType: ResType; theData: Handle);
  1428.         function GetData (theType: ResType; var theData: Handle): Boolean;
  1429.         function DataSize (theType: ResType): Longint;
  1430.         procedure PrivateChanged;
  1431.         procedure UpdateDisplay;
  1432.         function MakeClipView (dataType: ResType; dataHandle: Handle): CPanorama;
  1433.     end;
  1434.  
  1435.  
  1436. {****************************************************************************}
  1437. { CView}
  1438. {}
  1439. {    TCL 1.1 CHANGES}
  1440. {    [}
  1441. {        - added GetWantsClicks method}
  1442. {        - added fCanBeGopher instance variable, and SetCanBeGopher and}
  1443. {          CanBeGopher methods for accessing}
  1444. {        - added ID instance variable, GetID, SetID,}
  1445. {          and FindByID methods}
  1446. {        - added MatchView method}
  1447. {        - added ForcePrepare method}
  1448. {        - for 32-bit view support, changed GetFrame, GetInterior, GetAperture,}
  1449. {          and FrameToGlobalR to use LongRects.}
  1450. {        - added usingLongCoord instance variable and UseLongCoordinates}
  1451. {          method.}
  1452. {        - added ForceNextPrepare static method}
  1453. {        - moved TrackMouse to CPane. It needs access to some coordinate}
  1454. {          transformations provided by CPane.}
  1455. {        - added helpResIndex instance variable, and GetBalloonInfo, ShowHelpBalloon, }
  1456. {          and GetHelpResID methods}
  1457. {        - added cPreparedView, cCurrHelpView, cLastHelpView,}
  1458. {          class variables}
  1459. {    ]}
  1460. {****************************************************************************}
  1461.  
  1462.  
  1463. type
  1464. CView = object(CBureaucrat)
  1465.  
  1466.         macPort: GrafPtr;        { Mac drawing port for the image    }
  1467.         itsEnclosure: CView;    { Enclosing view                    }
  1468.         itsSubviews: CList;    { Views within this view            }
  1469.         visible: Boolean;        { Is the view visible?                }
  1470.         active: Boolean;        { Is the view active?                }
  1471.         wantsClicks: Boolean;    { Does view handle mouse clicks?    }
  1472.         fCanBeGopher: Boolean;    { Can this view become the gopher? }
  1473.         ID: Longint;            { identifier for this view            }
  1474.         usingLongCoord: Boolean; { TRUE if using 32-bit coordinates    }
  1475.         helpResIndex: Integer; { ballon help info for the view    }
  1476.  
  1477.         procedure IView (anEnclosure: CView; aSupervisor: CBureaucrat);
  1478.         procedure IViewRes (rType: ResType; resID: Integer; anEnclosure: CView; aSupervisor: CBureaucrat);
  1479.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  1480.         procedure Free;
  1481.         OVERRIDE;
  1482.         function IsVisible: Boolean;
  1483.         function IsActive: Boolean;
  1484.         function ReallyVisible: Boolean;
  1485.         function GetMacPort: GrafPtr;
  1486.         procedure GetOrigin (var theHOrigin: Longint; var theVOrigin: Longint);
  1487.         procedure GetFrame (var theFrame: LongRect);
  1488.         procedure GetInterior (var theInterior: LongRect);
  1489.         procedure GetAperture (var theAperture: LongRect);
  1490.         function Contains (thePoint: Point): Boolean;
  1491.         procedure SetWantsClicks (aWantsClicks: Boolean);
  1492.         function GetWantsClicks: Boolean;
  1493.         procedure SetCanBeGopher (aCanBeGopher: Boolean);
  1494.         function CanBeGopher: Boolean;
  1495.         procedure SetID (anIdentifier: Longint);
  1496.         function GetID: Longint;
  1497.         procedure UseLongCoordinates (fUsing: Boolean);
  1498.         procedure Show;
  1499.         procedure Hide;
  1500.         procedure Activate;
  1501.         procedure Deactivate;
  1502.         procedure DispatchClick (var macEvent: EventRecord);
  1503.         procedure DoClick (hitPt: Point; modifierKeys: Integer; when: Longint);
  1504.         function HitSamePart (pointA: Point; pointB: Point): Boolean;
  1505.         procedure DoMouseUp (VAR macEvent: EventRecord);
  1506.         procedure DispatchCursor (where: Point; mouseRgn: RgnHandle);
  1507.         procedure AdjustCursor (where: Point; mouseRgn: RgnHandle);
  1508.         procedure GetBalloonInfo (var helpData: HMMessageRecord; var tip: Point; var alternateRect: Rect; var tipProc: Ptr; var theProc, variant, method: Integer);
  1509.         procedure ShowHelpBalloon (helpData: HMMessageRecord; tip: Point; alternateRect: Rect; tipProc: Ptr; theProc, variant, method: Integer);
  1510.         function GetHelpResID: Integer;
  1511.         procedure AddSubview (theSubview: CView);
  1512.         procedure RemoveSubview (theSubview: CView);
  1513.         function FindSubview (hitPt: Point): CView;
  1514.         procedure SubpaneLocation (hEncl: Longint; vEncl: Longint; var hLocation: Longint; var vLocation: Longint);
  1515.         function FindViewByID (anID: Longint): CView;
  1516.         function CView.MatchView (function matchProc (aView: CView): Boolean): CView;
  1517.         procedure Prepare;
  1518.         procedure FrameToGlobalR (frameRect: LongRect; var globalRect: Rect);
  1519.     end;
  1520.  
  1521. { View template                    }
  1522. type
  1523. ViewTemp = record
  1524.         visible: Integer;
  1525.         active: Integer;
  1526.         wantsClicks: Integer;
  1527.     end;
  1528. ViewTempP = ^ViewTemp;
  1529.  
  1530. var        { CLASS VARIABLES }
  1531.  
  1532. cPreparedView: CView; { currently Prepared view        }
  1533. cCurrHelpView: CView; { used for Balloon help            }
  1534. cLastHelpView: CView; { also for Balloon help            }
  1535.  
  1536. procedure ForceNextPrepare;
  1537.  
  1538. {****************************************************************************}
  1539. { CWindow}
  1540. {}
  1541. {    TCL 1.1 CHANGES}
  1542. {    [}
  1543. {        - added isModal instance variable and IsModal method.}
  1544. {        - added INewWindow method to support creation without WIND resource}
  1545. {        - added procID instance variable to remember the defproc ID used}
  1546. {          to create the window.}
  1547. {        - added isColor instance variable and IsColor method}
  1548. {        - added helpResID instance variable, SetHelpResID, GetHelpResID}
  1549. {          methods}
  1550. {    ]}
  1551. {}
  1552. {****************************************************************************}
  1553.  
  1554. type
  1555.  
  1556. WStateDataP = ^WStateData;
  1557. WStateDataH = ^WStateDataP;
  1558.  
  1559.  
  1560. CWindow = object(CView)
  1561.  
  1562.         procID: Integer;    { defproc ID used to create the window }
  1563.         sizeRect: Rect;        { Max and Min size for the window    }
  1564.         floating: Boolean;    { Is this a floating window?        }
  1565.         fIsColor: Boolean;    { Is this a color window?            }
  1566.         fIsModal: Boolean;    { Is it currently modal?            }
  1567.         actClick: Boolean;    { Does it process a mouse click    }
  1568.                             {   which activates the window?    }
  1569.         location: Point;    { Location of window, used when    }
  1570.                             {   "hiding" while suspended        }
  1571.  
  1572.         helpResID: Integer;{ index of 'hrct' resource for        }
  1573.                             { help balloons                    }
  1574.  
  1575.         procedure IWindow (WINDid: Integer; aFloating: Boolean; anEnclosure: CDesktop; aSupervisor: CDirector);
  1576.         procedure INewWindow (bounds: Rect; fVisible: Boolean; aProcID: Integer; fFloating: Boolean; fHasGoAway: Boolean; anEnclosure: CDesktop; aSupervisor: CDirector);
  1577.         procedure IWindowX;
  1578.         procedure Free;
  1579.         OVERRIDE;
  1580.         procedure MakeMacWindow (WINDid: Integer);
  1581.         procedure MakeNewMacWindow (bounds: Rect; aProcID: Integer; fHasGoAway: Boolean);
  1582.         procedure Close;
  1583.         procedure GetFrame (var theFrame: LongRect);
  1584.         OVERRIDE;
  1585.         procedure GetInterior (var theInterior: LongRect);
  1586.         OVERRIDE;
  1587.         procedure GetAperture (var theAperture: LongRect);
  1588.         OVERRIDE;
  1589.         function IsFloating: Boolean;
  1590.         function IsModal: Boolean;
  1591.         function IsColor: Boolean;
  1592.         procedure SetModal (fModal: Boolean);
  1593.         procedure SetTitle (theTitle: Str255);
  1594.         procedure GetTitle (var theTitle: Str255);
  1595.         procedure SetActClick (anActClick: Boolean);
  1596.         function WantsActClick: Boolean;
  1597.         function Contains (thePoint: Point): Boolean;
  1598.         OVERRIDE;
  1599.         procedure SetSizeRect (aSizeRect: Rect);
  1600.         procedure SetStdState (aStdState: Rect);
  1601.         procedure SetHelpResID (aResID: Integer);
  1602.         function GetHelpResID: Integer;
  1603.         OVERRIDE;
  1604.         procedure Show;
  1605.         OVERRIDE;
  1606.         procedure Hide;
  1607.         OVERRIDE;
  1608.         procedure Activate;
  1609.         OVERRIDE;
  1610.         procedure Deactivate;
  1611.         OVERRIDE;
  1612.         procedure Select;
  1613.         procedure ShowResume;
  1614.         procedure HideSuspend;
  1615.         procedure ShowOrHide (showFlag: Boolean);
  1616.         procedure Drag (VAR macEvent: EventRecord);
  1617.         procedure Resize (VAR macEvent: EventRecord);
  1618.         procedure Zoom (direction: Integer);
  1619.         procedure Move (hGlobal: Integer; vGlobal: Integer);
  1620.         procedure ChangeSize (width: Integer; height: Integer);
  1621.         procedure MoveOffScreen;
  1622.         procedure Update;
  1623.         procedure Prepare;
  1624.         OVERRIDE;
  1625.         procedure DispatchClick (var macEvent: EventRecord);
  1626.         OVERRIDE;
  1627.         procedure DispatchCursor (where: Point; mouseRgn: RgnHandle);
  1628.         OVERRIDE;
  1629.         procedure FrameToGlobalR (frameRect: LongRect; var globalRect: Rect);
  1630.         OVERRIDE;
  1631.     end;
  1632.  
  1633. { symbolic constants for Boolean parameters}
  1634. const
  1635. kModeless = FALSE;
  1636. kModal = TRUE;
  1637.  
  1638. kNotVisible = FALSE;
  1639. kVisible = TRUE;
  1640.  
  1641. kNoGoAway = FALSE;
  1642. kHasGoAway = TRUE;
  1643.  
  1644. kNotFloating = FALSE;
  1645. kFloating = TRUE;
  1646.  
  1647. {****************************************************************************}
  1648. { CDesktop}
  1649. {}
  1650. {****************************************************************************}
  1651.  
  1652. type
  1653. CDesktop = object(CView)
  1654.  
  1655.         bounds: Rect;            { Boundaries of the Desktop        }
  1656.         itsWindows: CList;        { Application windows                }
  1657.         topWindow: CWindow;        { Topmost visible window            }
  1658.  
  1659.         procedure IDesktop (aSupervisor: CBureaucrat);
  1660.         procedure Free;
  1661.         OVERRIDE;
  1662.         procedure Show;
  1663.         OVERRIDE;
  1664.         procedure Hide;
  1665.         OVERRIDE;
  1666.         procedure Activate;
  1667.         OVERRIDE;
  1668.         procedure Deactivate;
  1669.         OVERRIDE;
  1670.         function ReallyVisible: Boolean;
  1671.         OVERRIDE;
  1672.         procedure DispatchClick (var macEvent: EventRecord);
  1673.         OVERRIDE;
  1674.         procedure DoMouseUp (VAR macEvent: EventRecord);
  1675.         OVERRIDE;
  1676.         procedure DispatchCursor (where: Point; mouseRgn: RgnHandle);
  1677.         OVERRIDE;
  1678.         procedure AdjustCursor (where: Point; mouseRgn: RgnHandle);
  1679.         OVERRIDE;
  1680.         function Contains (thePoint: Point): Boolean;
  1681.         OVERRIDE;
  1682.         function HitSamePart (pointA: Point; pointB: Point): Boolean;
  1683.         OVERRIDE;
  1684.         procedure AddWind (theWindow: CWindow);
  1685.         procedure RemoveWind (theWindow: CWindow);
  1686.         procedure SelectWind (theWindow: CWindow);
  1687.         procedure ShowWind (theWindow: CWindow);
  1688.         procedure HideWind (theWindow: CWindow);
  1689.         procedure DragWind (theWindow: CWindow; VAR macEvent: EventRecord);
  1690.         procedure UpdateWindows;
  1691.         function GetTopWindow: CWindow;
  1692.         function GetBottomWindow: CWindow;
  1693.         procedure GetBounds (var theBounds: Rect);
  1694.         procedure GetAperture (var theAperture: LongRect);
  1695.         OVERRIDE;
  1696.         procedure Prepare;
  1697.         OVERRIDE;
  1698.         procedure Cleanup;
  1699.     end;
  1700.  
  1701.  
  1702. {****************************************************************************}
  1703. { CPane}
  1704. {}
  1705. {    TCL 1.1 CHANGES}
  1706. {    [}
  1707. {        - added GetWindow method}
  1708. {        - added instance variable itsBorder, and SetBorder, GetBorder,}
  1709. {          SetResBorder, and RefreshBorder methods}
  1710. {        - Moved TrackMouse from CView to CPane.}
  1711. {        - for 32-bit support, changed instance variables hEncl, vEncl, }
  1712. {          frame, and aperture to use long coordinates. Also changed }
  1713. {          interface for SetFrameOrigin, GetFrame, GetAperture, Place, }
  1714. {          Offset, EnclosureScrolled, WindToFrame, WindToFrameR, FrameToWind, }
  1715. {          FrameToWindR, EnclToFrame, EnclToFrameR, FrameToEncl, FrameToEnclR, }
  1716. {          and FrameToGlobalR methods to use long coordinates.}
  1717. {        - added new methods RefreshLongRect, QDToFrame, QDToFrameR, }
  1718. {          FrameToQD, FrameToQDR, and SectAperture, GetHelpResID}
  1719. {    ]}
  1720. {}
  1721. {****************************************************************************}
  1722. type
  1723.  
  1724.     { How pane changes size when the size of its enclosure changes }
  1725.  
  1726. SizingOption = (sizFIXEDLEFT,    { Fixed length, anchored to left        }
  1727.     sizFIXEDRIGHT,                    { Fixed length, anchored to right    }
  1728.     sizFIXEDTOP,                    { Fixed length, anchored to top        }
  1729.     sizFIXEDBOTTOM,                { Fixed length, anchored to bottom    }
  1730.     sizFIXEDSTICKY,                { Fixed length, sticks to coords        }
  1731.                                     {   of its enclosure                    }
  1732.     sizELASTIC                        { Variable length, always a fixed    }
  1733.                                     {   amount smaller than enclosure    }
  1734.     );
  1735.  
  1736. ClipOption = (clipAPERTURE, clipFRAME, clipPAGE);
  1737.  
  1738. CPane = object(CView)
  1739.  
  1740.         width: Integer;        { Horizontal size in pixels        }
  1741.         height: Integer;        { Vertical size in pixels            }
  1742.         hEncl: Longint;            { Horizontal location in enclosure    }
  1743.         vEncl: Longint;            { Vertical location in enclosure    }
  1744.         hSizing: SizingOption;    { Horizontal sizing option            }
  1745.         vSizing: SizingOption;    { Vertical sizing option            }
  1746.         autoRefresh: Boolean;    { Refresh all after a resize?        }
  1747.         frame: LongRect;        { Area for displaying the Pane        }
  1748.                                 {   which defines Frame coords        }
  1749.         aperture: LongRect;        { Active drawing area of the Pane    }
  1750.         hOrigin: Longint;        { Window left in Frame coords        }
  1751.         vOrigin: Longint;        { Window top in Frame coords        }
  1752.         itsEnvironment: CEnvironment;    { Drawing environment        }
  1753.         printClip: ClipOption;    { Clipping option when printing    }
  1754.         printing: Boolean;        { Is printing in progress?            }
  1755.         itsBorder: CPaneBorder;    { border of this pane                }
  1756.  
  1757.         itsLastTask: CTask;        { subclasses should always make    }
  1758.                                 { sure that itsLastTask points to    }
  1759.                                 { the last CTask subclass created    }
  1760.                                 { by the pane. The Dispose         }
  1761.                                 { method will make sure that the    }
  1762.                                 { task is disposed when the pane    }
  1763.                                 { is disposed. This is important    }
  1764.                                 { because most tasks refer back to    }
  1765.                                 { the originating pane and would    }
  1766.                                 { be left with a dangling pointer.    }
  1767.  
  1768.  
  1769.         procedure IPane (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption);
  1770.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  1771.         OVERRIDE;
  1772.         procedure IPaneX;
  1773.         procedure Free;
  1774.         OVERRIDE;
  1775.         procedure SetFrameOrigin (fLeft: Longint; fTop: Longint);
  1776.         procedure GetFrame (var theFrame: LongRect);
  1777.         OVERRIDE;
  1778.         procedure GetLengths (var theWidth, theHeight: Integer);
  1779.         procedure GetOrigin (var theHOrigin, theVOrigin: Longint);
  1780.         OVERRIDE;
  1781.         procedure GetAperture (var theAperture: LongRect);
  1782.         OVERRIDE;
  1783.         function Contains (thePoint: Point): Boolean;
  1784.         OVERRIDE;
  1785.         function ReallyVisible: Boolean;
  1786.         OVERRIDE;
  1787.         procedure GetPixelExtent (var hExtent: Longint; var vExtent: Longint);
  1788.         procedure SetPrintClip (aPrintClip: ClipOption);
  1789.         function GetWindow: CWindow;
  1790.         procedure SetBorder (aBorder: CPaneBorder);
  1791.         procedure SetResBorder (resID: Integer);
  1792.         function GetBorder: CPaneBorder;
  1793.         function GetHelpResID: Integer;
  1794.         OVERRIDE;
  1795.         procedure Show;
  1796.         OVERRIDE;
  1797.         procedure Hide;
  1798.         OVERRIDE;
  1799.         procedure Place (aHEncl: Longint; aVEncl: Longint; redraw: Boolean);
  1800.         procedure Offset (hOffset: Longint; vOffset: Longint; redraw: Boolean);
  1801.         procedure ChangeSize (delta: Rect; redraw: Boolean);
  1802.         procedure AdjustToEnclosure (deltaEncl: Rect);
  1803.         procedure AdjustHoriz (deltaEncl: Rect; var delta: Rect; var theOffset: Integer; var moved: Boolean; var sized: Boolean);
  1804.         procedure AdjustVert (deltaEncl: Rect; var delta: Rect; var theOffset: Integer; var moved: Boolean; var sized: Boolean);
  1805.         procedure EnclosureScrolled (hOffset: Longint; vOffset: Longint);
  1806.         procedure FitToEnclosure (horizFit: Boolean; vertFit: Boolean);
  1807.         procedure FitToEnclFrame (horizFit: Boolean; vertFit: Boolean);
  1808.         procedure CenterWithinEnclosure (horizCenter: Boolean; vertCenter: Boolean);
  1809.         procedure Draw (var area: Rect);
  1810.         procedure DrawAll (var area: Rect);
  1811.         procedure Refresh;
  1812.         procedure RefreshRect (area: Rect);
  1813.         procedure RefreshLongRect (area: LongRect);
  1814.         procedure RefreshBorder;
  1815.         procedure Paginate (aPrinter: CPrinter; pageWidth: Integer; pageHeight: Integer);
  1816.         procedure AboutToPrint (var firstPage: Integer; var lastPage: Integer);
  1817.         procedure PrintPage (pageNum: Integer; pageWidth: Integer; pageHeight: Integer; aPrinter: CPrinter);
  1818.         procedure DonePrinting;
  1819.         procedure PrepareToPrint;
  1820.         procedure Prepare;
  1821.         OVERRIDE;
  1822.         procedure RestoreEnvironment;
  1823.         procedure CalcFrame;
  1824.         procedure ResizeFrame (delta: Rect);
  1825.         procedure CalcAperture;
  1826.         procedure TrackMouse (theTask: CMouseTask; startPt: LongPt; var pinRect: LongRect);
  1827.         procedure WindToFrame (qdPt: Point; var framePt: LongPt);
  1828.         procedure WindToFrameR (qdRect: Rect; var frameRect: LongRect);
  1829.         procedure FrameToWind (framePt: LongPt; var qdPt: Point);
  1830.         procedure FrameToWindR (frameRect: LongRect; var qdRect: Rect);
  1831.         procedure EnclToFrame (var thePoint: LongPt);
  1832.         procedure EnclToFrameR (var theRect: LongRect);
  1833.         procedure FrameToEncl (var thePoint: LongPt);
  1834.         procedure FrameToEnclR (var theRect: LongRect);
  1835.         procedure FrameToGlobalR (frameRect: LongRect; var globalRect: Rect);
  1836.         OVERRIDE;
  1837.         procedure QDToFrame (qdPt: Point; var framePt: LongPt);
  1838.         procedure QDToFrameR (qdRect: Rect; var frameRect: LongRect);
  1839.         procedure FrameToQD (framePt: LongPt; var qdPt: Point);
  1840.         procedure FrameToQDR (frameRect: LongRect; var qdRect: Rect);
  1841.         function SectAperture (srcRect: LongRect; var destRect: Rect): Boolean;
  1842.     end;
  1843.  
  1844.  
  1845. { Pane template                    }
  1846.  
  1847. PaneTemp = record
  1848.         sViewTemp: ViewTemp;
  1849.         width: Integer;
  1850.         height: Integer;
  1851.         hEncl: Integer;
  1852.         vEncl: Integer;
  1853.         hSizing: Integer;
  1854.         vSizing: Integer;
  1855.         autoRefresh: Integer;
  1856.         printClip: Integer;
  1857.     end;
  1858.  
  1859. PaneTempP = ^PaneTemp;
  1860.  
  1861. { TRUE/FALSE synonyms for some common Boolean parameters }
  1862. const
  1863. kNoRedraw = FALSE;
  1864. kRedraw = TRUE;
  1865.  
  1866. kNotHorizontal = FALSE;
  1867. kDoHorizontal = TRUE;
  1868.  
  1869. kNotVertical = FALSE;
  1870. kDoVertical = TRUE;
  1871.  
  1872.  
  1873. var
  1874. cPageArea: Rect; { area of page being printed        }
  1875.  
  1876.  
  1877. {****************************************************************************}
  1878. { CControl}
  1879. {        }
  1880. {    TCL 1.1 CHANGES}
  1881. {    [}
  1882. {        - added constants for CControl change protocol.}
  1883. {    ]}
  1884. {}
  1885. {****************************************************************************}
  1886.  
  1887. type
  1888. CControl = object(CPane)
  1889.  
  1890.  
  1891.         macControl: ControlHandle;            { Toolbox control record            }
  1892.  
  1893.  
  1894.                                             { Destruction }
  1895.         procedure Free;
  1896.         override;
  1897.  
  1898.                                             { Accessing }
  1899.  
  1900.         procedure SetValue (aValue: integer);
  1901.         function GetValue: integer;
  1902.         procedure SetMaxValue (aMaxValue: integer);
  1903.         function GetMaxValue: integer;
  1904.         procedure SetMinValue (aMinValue: integer);
  1905.         function GetMinValue: integer;
  1906.         procedure SetTitle (aTitle: Str255);
  1907.         procedure GetTitle (var aTitle: Str255);
  1908.         procedure SetActionProc (anActionProc: ControlActionUPP);
  1909.  
  1910.                                             { Manipulating }
  1911.         procedure Show;
  1912.         override;
  1913.         procedure Hide;
  1914.         override;
  1915.         procedure Activate;
  1916.         override;
  1917.         procedure Deactivate;
  1918.         override;
  1919.         procedure Offset (hOffset: Longint; vOffset: Longint; redraw: Boolean);
  1920.         override;
  1921.         procedure ChangeSize (delta: Rect; redraw: Boolean);
  1922.         override;
  1923.  
  1924.                                             { Drawing }
  1925.  
  1926.         procedure Draw (var area: Rect);
  1927.         override;
  1928.         procedure DrawAll (var area: Rect);
  1929.         override;
  1930.         procedure Prepare;
  1931.         override;
  1932.         procedure PrepareToPrint;     { TCL 1.1.1 DLP 9/25/91 }
  1933.         override;
  1934.  
  1935.                                             { Click Response }
  1936.  
  1937.         procedure DoClick (hitPt: Point; modifierKeys: integer; when: longint);
  1938.         override;
  1939.         procedure DoThumbDragged (delta: integer);
  1940.         procedure DoGoodClick (whichPart: integer);
  1941.         procedure RefreshLongRect (area: LongRect);
  1942.         OVERRIDE;
  1943.     end;
  1944.  
  1945.  
  1946. CNTLtemplate = record
  1947.         boundsRect: Rect;
  1948.         value: Integer;
  1949.         visible: Integer;
  1950.         max: Integer;
  1951.         min: Integer;
  1952.         procID: Integer;
  1953.         refcon: Longint;
  1954.         title: Str255;
  1955.     end;
  1956. CNTLtemplatePtr = ^CNTLtemplate;
  1957. CNTLtemplateHndl = ^CNTLtemplatePtr;
  1958.  
  1959. { Change protocol for CControl }
  1960. const
  1961.  
  1962.     { The value of the control has changed. The info parameter is    }
  1963.     { a pointer (IntegerPtr) to the new value                         }
  1964.  
  1965. controlValueChanged = bureaucratLastChange + 1;
  1966.  
  1967. controlLastChange = controlValueChanged;
  1968.  
  1969.  
  1970. {****************************************************************************}
  1971. { CPanorama}
  1972. {}
  1973. {    TCL 1.1 CHANGES}
  1974. {    [}
  1975. {        - To accomodate 32 bit coordinates, changed instance variables}
  1976. {          bounds, position, and savePosition.}
  1977. {        - Changed interface for SetBounds, GetBounds, SetPosition, GetPosition,}
  1978. {          GetHomePosition, ScrollTo, SetBounds, and GetBounds }
  1979. {          to accomodate 32 bit coordinates.    }
  1980. {        - added ClipToAperture method      }
  1981. {    ]}
  1982. {}
  1983. {****************************************************************************}
  1984.  
  1985. type
  1986. CPanorama = object(CPane)
  1987.  
  1988.         bounds: LongRect;
  1989.         hScale: Integer;
  1990.         vScale: Integer;
  1991.         position: LongPt;
  1992.         savePosition: LongPt;
  1993.         itsScrollPane: CScrollPane;
  1994.  
  1995.         procedure IPanorama (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption);
  1996.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  1997.         OVERRIDE;
  1998.         procedure GetExtent (var theHExtent: Longint; var theVExtent: Longint);
  1999.         procedure GetFramePosition (var theHPos: Longint; var theVPos: Longint);
  2000.         procedure GetFrameSpan (var theHSpan, theVSpan: Integer);
  2001.         procedure SetBounds (aBounds: LongRect);
  2002.         procedure GetBounds (var theBounds: LongRect);
  2003.         procedure SetPosition (aPosition: LongPt);
  2004.         procedure GetPosition (var thePos: LongPt);
  2005.         procedure SetScales (aHScale: Integer; aVScale: Integer);
  2006.         procedure GetScales (var theHScale, theVScale: Integer);
  2007.         procedure SetScrollPane (aScrollPane: CScrollPane);
  2008.         procedure GetHomePosition (var theHomePos: LongPt);
  2009.         procedure GetPixelExtent (var hExtent: Longint; var vExtent: Longint);
  2010.         OVERRIDE;
  2011.         procedure ResizeFrame (delta: Rect);
  2012.         OVERRIDE;
  2013.         procedure Scroll (hDelta: Longint; vDelta: Longint; redraw: Boolean);
  2014.         procedure ScrollTo (aPosition: LongPt; redraw: Boolean);
  2015.         procedure ScrollToSelection;
  2016.         function AutoScroll (mouseLoc: LongPt): Boolean;
  2017.         procedure DoKeyDown (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  2018.         OVERRIDE;
  2019.         procedure Paginate (aPrinter: CPrinter; pageWidth: Integer; pageHeight: Integer);
  2020.         OVERRIDE;
  2021.         procedure AboutToPrint (var firstPage: Integer; var lastPage: Integer);
  2022.         OVERRIDE;
  2023.         procedure PrintPage (pageNum: Integer; pageWidth: Integer; pageHeight: Integer; aPrinter: CPrinter);
  2024.         OVERRIDE;
  2025.         procedure DonePrinting;
  2026.         OVERRIDE;
  2027.     end;
  2028.  
  2029. { Panorama template                    }
  2030. type
  2031. PanoramaTemp = record
  2032.         sPaneTemp: PaneTemp;
  2033.         bounds: Rect;
  2034.         hScale: Integer;
  2035.         vScale: Integer;
  2036.         position: Point;
  2037.     end;
  2038.  
  2039. PanoramaTempP = ^PanoramaTemp;
  2040.  
  2041. {****************************************************************************}
  2042. { CPicture}
  2043. {}
  2044. {****************************************************************************}
  2045.  
  2046. type
  2047. CPicture = object(CPanorama)
  2048.         macPicture: PicHandle;
  2049.         scaled: Boolean;
  2050.         isResPicture: Boolean;
  2051.         ownsPicture: Boolean;
  2052.         procedure IPicture (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption);
  2053.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  2054.         OVERRIDE;
  2055.         procedure Free;
  2056.         OVERRIDE;
  2057.         procedure Draw (var area: Rect);
  2058.         OVERRIDE;
  2059.         procedure SetMacPicture (aMacPicture: PicHandle);
  2060.         procedure UsePICT (PICTid: Integer);
  2061.         function GetMacPicture: PicHandle;
  2062.         procedure SetScaled (aScaled: Boolean);
  2063.         function GetScaled: Boolean;
  2064.         procedure ResizeFrame (delta: Rect);
  2065.         OVERRIDE;
  2066.         procedure FrameToBounds;
  2067.     end;
  2068.  
  2069. { Picture Pane template                }
  2070. type
  2071. PictureTemp = record
  2072.         sPanoramaTemp: PanoramaTemp;
  2073.         PICTid: Integer;
  2074.         scaled: Integer;
  2075.     end;
  2076.  
  2077. PictureTempP = ^PictureTemp;
  2078.  
  2079. {****************************************************************************}
  2080. { CScrollBar}
  2081. {}
  2082. {****************************************************************************}
  2083. type
  2084.  
  2085. Orientation = (HORIZONTAL, VERTICAL);
  2086.  
  2087. CScrollBar = object(CControl)
  2088.  
  2089.         theOrientation: Orientation;
  2090.         theThumbFunc: ControlActionUPP;
  2091.  
  2092.         procedure IScrollBar (anEnclosure: CView; aSupervisor: CBureaucrat; anOrientation: Orientation; aLength: Integer; aHEncl: Integer; aVEncl: Integer);
  2093.         procedure SetThumbFunc (aThumbFunc: ControlActionUPP);
  2094.         procedure Draw (var area: Rect);
  2095.         OVERRIDE;
  2096.         procedure Activate;
  2097.         OVERRIDE;
  2098.         procedure Deactivate;
  2099.         OVERRIDE;
  2100.         procedure DoClick (hitPt: Point; modifierKeys: Integer; when: Longint);
  2101.         OVERRIDE;
  2102.         procedure DoThumbDragged (delta: Integer);
  2103.         OVERRIDE;
  2104.     end;
  2105.  
  2106. procedure CallTheThumbFunc (theScrollBar: CScrollBar; delta: integer; thumbFunc: ControlActionUPP);
  2107. {$IFC MAC68K}
  2108. inline
  2109. $205F,         {    MOVEA.L    (A7)+, A0        }
  2110. $4E90;         {    JSR         (A0)        }
  2111. {$ENDC}
  2112.  
  2113. {****************************************************************************}
  2114. { CScrollPane}
  2115. {}
  2116. {    TCL 1.1 CHANGES}
  2117. {    [}
  2118. {        - added DoScroll method}
  2119. {    ]}
  2120. {}
  2121. {****************************************************************************}
  2122.  
  2123. type
  2124. CScrollPane = object(CPane)
  2125.         itsPanorama: CPanorama;        { View which scrolls                }
  2126.         itsHorizSBar: CScrollBar;    { Horizontal scroll bar            }
  2127.         itsVertSBar: CScrollBar;    { Vertical scroll bar                }
  2128.         itsSizeBox: CSizeBox;        { Grow box                            }
  2129.         hExtent: Longint;
  2130.         vExtent: Longint;
  2131.         hUnit: Integer;
  2132.         vUnit: Integer;
  2133.         hSpan: Integer;
  2134.         vSpan: Integer;
  2135.         hStep: Integer;
  2136.         vStep: Integer;
  2137.         hOverlap: Integer;
  2138.         vOverlap: Integer;
  2139.  
  2140.         procedure IScrollPane (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption; hasHoriz: Boolean; hasVert: Boolean; hasSizeBox: Boolean);
  2141.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  2142.         OVERRIDE;
  2143.         procedure IScrollPaneX (hasHoriz: Boolean; hasVert: Boolean; hasSizeBox: Boolean);
  2144.         procedure InstallPanorama (aPanorama: CPanorama);
  2145.         procedure SetSteps (aHStep: Integer; aVStep: Integer);
  2146.         procedure GetSteps (var theHStep: Integer; var theVStep: Integer);
  2147.         procedure SetOverlaps (aHOverlap: Integer; aVOverlap: Integer);
  2148.         procedure GetInterior (var theInterior: LongRect);
  2149.         OVERRIDE;
  2150.         procedure AdjustScrollMax;
  2151.         procedure Calibrate;
  2152.         procedure ChangeSize (delta: Rect; redraw: Boolean);
  2153.         OVERRIDE;
  2154.         procedure DoHorizScroll (whichPart: Integer);
  2155.         procedure DoVertScroll (whichPart: Integer);
  2156.         procedure DoThumbDrag (hDelta: Integer; vDelta: Integer);
  2157.         procedure DoScroll (hDelta: Longint; vDelta: Longint);
  2158.     end;
  2159.  
  2160. { ScrollPane template                    }
  2161. type
  2162. ScrollPaneTemp = record
  2163.         sPaneTemp: PaneTemp;
  2164.         hStep: Integer;
  2165.         vStep: Integer;
  2166.         hOverlap: Integer;
  2167.         vOverlap: Integer;
  2168.         hasHoriz: Integer;
  2169.         hasVert: Integer;
  2170.         hasSizeBox: Integer;
  2171.     end;
  2172.  
  2173. ScrollPaneTempP = ^ScrollPaneTemp;
  2174.  
  2175. { synonyms for some Boolean parameters}
  2176.  
  2177. const
  2178.  
  2179. kNoHScroll = FALSE;
  2180. kHasHScroll = TRUE;
  2181.  
  2182. kNoVScroll = FALSE;
  2183. kHasVScroll = TRUE;
  2184.  
  2185. kNoSizebox = FALSE;
  2186. kHasSizebox = TRUE;
  2187.  
  2188.  
  2189. {****************************************************************************}
  2190. { CSizeBox}
  2191. {}
  2192. {    TCL 1.1 CHANGES}
  2193. {    [}
  2194. {        - added useSICN instance variable. Determines whether a SICN resource}
  2195. {          or the DrawGrowIcon trap is used to draw the size box.}
  2196. {    ]}
  2197. {}
  2198. {****************************************************************************}
  2199.  
  2200. type
  2201. CSizeBox = object(CPane)
  2202.         useSICN: Boolean;
  2203.         procedure ISizeBox (anEnclosure: CView; aSupervisor: CBureaucrat);
  2204.         procedure Draw (var area: Rect);
  2205.         OVERRIDE;
  2206.         procedure Activate;
  2207.         OVERRIDE;
  2208.         procedure Deactivate;
  2209.         OVERRIDE;
  2210.     end;
  2211.  
  2212. {****************************************************************************}
  2213. { CAbstractText}
  2214. {****************************************************************************}
  2215. type
  2216.  
  2217.     { buffer for a single character, allowing for multi-byte scripts    }
  2218.     { first byte is length-byte, as in a Pascal string                    }
  2219.  
  2220. tCharBuf = string[5];
  2221.  
  2222. CAbstractText = object(CPanorama)
  2223.  
  2224.         itsTypingTask: CTextEditTask;
  2225.         fixedLineHeights: Boolean;
  2226.         wholeLines: Boolean;
  2227.         editable: Boolean;
  2228.         stylable: Boolean;
  2229.         lineWidth: Integer;
  2230.         lastFontNum: Integer;
  2231.         lastFontCmd: Longint;
  2232.         lastTextSize: Integer;
  2233.         lastSizeCmd: Longint;
  2234.  
  2235.         procedure IAbstractText (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption; aLineWidth: Integer);
  2236.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  2237.         OVERRIDE;
  2238.         procedure SetTextString (textStr: Str255);
  2239.         procedure SetTextHandle (textHand: Handle);
  2240.         procedure SetTextPtr (textPtr: Ptr; numChars: Longint);
  2241.         function GetTextHandle: Handle;
  2242.         function CopyTextRange (startPos: Longint; endPos: Longint): Handle;
  2243.         procedure InsertTextPtr (text: Ptr; length: Longint; fRedraw: Boolean);
  2244.         procedure InsertTextHandle (text: Handle; fRedraw: Boolean);
  2245.         procedure Specify (fEditable, fSelectable, fStylable: Boolean);
  2246.         procedure GetSpecification (var fEditable, fSelectable, fStylable: Boolean);
  2247.         procedure SetFontNumber (aFontNumber: Integer);
  2248.         procedure SetFontName (aFontName: Str255);
  2249.         procedure SetFontStyle (aStyle: Style);
  2250.         procedure SetFontSize (aSize: Integer);
  2251.         procedure SetTextMode (aMode: Integer);
  2252.         procedure SetAlignCmd (anAlignCmd: Longint);
  2253.         function GetAlignCmd: Longint;
  2254.         procedure SetSpacingCmd (aSpacingCmd: Longint);
  2255.         function GetSpacingCmd: Longint;
  2256.         function GetHeight (startLine: Longint; endLine: Longint): Longint;
  2257.         function Get1Height (aLineNum: Longint): Integer;
  2258.         function GetCharOffset (aPt: LongPt): Longint;
  2259.         procedure GetCharPoint (theOffset: Longint; var aPt: LongPt);
  2260.         procedure GetCharStyle (charOffset: Longint; var theStyle: TextStyle);
  2261.         procedure GetTextStyle (var whichAttributes: Integer; var aStyle: TextStyle);
  2262.         procedure GetCharBefore (var aPosition: Longint; var charBuf: tCharBuf);
  2263.         procedure GetCharAfter (var aPosition: Longint; var charBuf: tCharBuf);
  2264.         procedure ResizeFrame (delta: Rect);
  2265.         OVERRIDE;
  2266.         procedure SetWholeLines (aWholeLines: Boolean);
  2267.         function GetWholeLines: Boolean;
  2268.         function FindLine (charPos: Longint): Longint;
  2269.         function GetLength: Longint;
  2270.         function GetNumLines: Longint;
  2271.         procedure DoCommand (theCommand: Longint);
  2272.         OVERRIDE;
  2273.         procedure PerformEditCommand (theCommand: Longint);
  2274.         procedure UpdateMenus;
  2275.         OVERRIDE;
  2276.         procedure DoKeyDown (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  2277.         OVERRIDE;
  2278.         procedure DoAutoKey (theChar: Char; keyCode: Byte; VAR macEvent: EventRecord);
  2279.         OVERRIDE;
  2280.         procedure TypeChar (theChar: Char; theModifiers: Integer);
  2281.         procedure SelectionChanged;
  2282.         procedure ScrollToSelection;
  2283.         OVERRIDE;
  2284.         function BecomeGopher (fBecoming: Boolean): Boolean;
  2285.         OVERRIDE;
  2286.         procedure SetSelection (selStart: Longint; selEnd: Longint; fRedraw: Boolean);
  2287.         procedure GetSelection (var selStart, selEnd: Longint);
  2288.         procedure SelectAll (fRedraw: Boolean);
  2289.         procedure Paginate (aPrinter: CPrinter; pageWidth, pageHeight: Integer);
  2290.         OVERRIDE;
  2291.         procedure AdjustCursor (where: Point; mouseRgn: RgnHandle);
  2292.         OVERRIDE;
  2293.         function MakeEditTask (editCmd: Longint): CTextEditTask;
  2294.         function MakeStyleTask (styleCmd: Longint): CTextStyleTask;
  2295.     end;
  2296.  
  2297. tAbstractTextTemp = record
  2298.         sPanoramaTemp: PanoramaTemp;
  2299.         lineWidth: Integer;
  2300.         wholeLines: Integer;
  2301.         editable: Integer;
  2302.         styleable: Integer;
  2303.     end;
  2304.  
  2305. tAbstractTextTempP = ^tAbstractTextTemp;
  2306.  
  2307.  
  2308. var
  2309. cFirstTaskIndex: Integer;
  2310.  
  2311. { Usage of cFirstTaskIndex:}
  2312. {}
  2313. {    CDocument updates the Undo menu item by sending a GetNameIndex message to the}
  2314. {    most recent task. The integer the task returns is used as an index into the}
  2315. {    STR# 130 resource, and the resulting string is used in the menu item text.}
  2316. {    }
  2317. {    CAbstractText, along with CTextEditTask and CStyleTask can perform a number of}
  2318. {    undoable operations, so more than one string is needed. The tasks assumes}
  2319. {    all the strings are located together in the STR# 130 resource, starting}
  2320. {    at the index given by the class variable cFirstTaskIndex. By default this}
  2321. {    index is 1, meaning these strings are the first in the STR# resource. }
  2322. {    It also expects them to be in the following order:}
  2323. {        Typing, Cut, Copy, Paste, Clear, Formatting}
  2324. {        }
  2325. {    If you have these strings at a different position in the resource, be sure}
  2326. {    to set cFirstTaskIndex at some point in your application resource. If you}
  2327. {    don't supply the strings at all, set cFirstTaskIndex to 0.}
  2328. {}
  2329. {)
  2330.  
  2331. { Usage of cFirstTaskIndex:}
  2332. {}
  2333. {    CDocument updates the Undo menu item by sending a GetNameIndex message to the}
  2334. {    most recent task. The integer the task returns is used as an index into the}
  2335. {    STR# 130 resource, and the resulting string is used in the menu item text.}
  2336. {    }
  2337. {    CAbstractText, along with CTextEditTask and CStyleTask can perform a number of}
  2338. {    undoable operations, so more than one string is needed. The tasks assumes}
  2339. {    all the strings are located together in the STR# 130 resource, starting}
  2340. {    at the index given by the class variable cFirstTaskIndex. By default this}
  2341. {    index is 1, meaning these strings are the first in the STR# resource. }
  2342. {    It also expects them to be in the following order:}
  2343. {        Typing, Cut, Copy, Paste, Clear, Formatting}
  2344. {        }
  2345. {    If you have these strings at a different position in the resource, be sure}
  2346. {    to set cFirstTaskIndex at some point in your application resource. If you}
  2347. {    don't supply the strings at all, set cFirstTaskIndex to 0.}
  2348. {}
  2349. {}
  2350.  
  2351. const
  2352.  
  2353. kAlignNotContinuous = MININT;    { alignment not continuous over selection }
  2354. kAlignJustify = 5;        { full justification                       }
  2355.  
  2356.     { mnemonic constants for the Specify method }
  2357.  
  2358. kNotEditable = FALSE;
  2359. kEditable = TRUE;
  2360.  
  2361. kNotSelectable = FALSE;
  2362. kSelectable = TRUE;
  2363.  
  2364. kNotStylable = FALSE;
  2365. kStylable = TRUE;
  2366.  
  2367.     { constants specifying the expected order of undo task names }
  2368.  
  2369. undoTyping = 0;
  2370. undoCut = 1;
  2371. undoCopy = 2;
  2372. undoPaste = 3;
  2373. undoClear = 4;
  2374. undoFormatting = 5;
  2375.  
  2376.     { Change protocol for CAbstractText:    info parameter not used    }
  2377.  
  2378. textSelectionChanged = bureaucratLastChange + 1;
  2379. textLastChange = textSelectionChanged;
  2380.  
  2381.  
  2382. {****************************************************************************}
  2383. { CEditText}
  2384. {}
  2385. {    TCL 1.1 CHANGES}
  2386. {    [}
  2387. {        - BIG CHANGE: EditText is now a subclass of CAbstractText, and}
  2388. {            CStaticText is a subclass of CEditText. Many, many things}
  2389. {            changed because of this. See comments in CEditText.p}
  2390. {    ]}
  2391. {}
  2392. {****************************************************************************}
  2393.  
  2394.  
  2395. type
  2396. CEditText = object(CAbstractText)
  2397.  
  2398.         macTE: TEHandle;
  2399.         spacingCmd: Longint;
  2400.         alignCmd: Longint;
  2401.  
  2402.         procedure IEditText (anEnclosure: CView; aSupervisor: CBureaucrat; aWidth: Integer; aHeight: Integer; aHEncl: Integer; aVEncl: Integer; aHSizing: SizingOption; aVSizing: SizingOption; aLineWidth: Integer);
  2403.         procedure IViewTemp (anEnclosure: CView; aSupervisor: CBureaucrat; viewData: Ptr);
  2404.         OVERRIDE;
  2405.         procedure IEditTextX;
  2406.         procedure MakeMacTE;
  2407.         procedure Free;
  2408.         OVERRIDE;
  2409.         procedure DoClick (hitPt: Point; modifierKeys: Integer; when: Longint);
  2410.         OVERRIDE;
  2411.         procedure PerformEditCommand (theCommand: Longint);
  2412.         OVERRIDE;
  2413.         procedure Draw (var area: Rect);
  2414.         OVERRIDE;
  2415.         procedure Scroll (hDelta, vDelta: Longint; redraw: Boolean);
  2416.         OVERRIDE;
  2417.         procedure Activate;
  2418.         OVERRIDE;
  2419.         procedure Deactivate;
  2420.         OVERRIDE;
  2421.         procedure SetSelection (selStart, selEnd: Longint; fRedraw: Boolean);
  2422.         OVERRIDE;
  2423.         procedure SetTextPtr (textPtr: Ptr; numChars: Longint);
  2424.         OVERRIDE;
  2425.         function GetTextHandle: Handle;
  2426.         OVERRIDE;
  2427.         function CopyTextRange (startPos, endPos: Longint): Handle;
  2428.         OVERRIDE;
  2429.         procedure InsertTextPtr (text: Ptr; length: Longint; fRedraw: Boolean);
  2430.         OVERRIDE;
  2431.         procedure TypeChar (theChar: Char; theModifiers: Integer);
  2432.         OVERRIDE;
  2433.         procedure CheckInsertion (insertLen: Longint; useSelection: Boolean);
  2434.         procedure CalcTERects;
  2435.         procedure ResizeFrame (delta: Rect);
  2436.         OVERRIDE;
  2437.         procedure AdjustBounds;
  2438.         function FindLine (charPos: Longint): Longint;
  2439.         OVERRIDE;
  2440.         function GetLength: Longint;
  2441.         OVERRIDE;
  2442.         procedure SetFontNumber (aFontNumber: Integer);
  2443.         OVERRIDE;
  2444.         procedure SetFontStyle (aStyle: Style);
  2445.         OVERRIDE;
  2446.         procedure SetFontSize (aSize: Integer);
  2447.         OVERRIDE;
  2448.         procedure SetTextMode (aMode: Integer);
  2449.         OVERRIDE;
  2450.         procedure SetAlignment (anAlignment: Integer);
  2451.         procedure SetAlignCmd (anAlignCmd: Longint);
  2452.         OVERRIDE;
  2453.         procedure SetSpacingCmd (aSpacingCmd: Longint);
  2454.         OVERRIDE;
  2455.         procedure GetTEFontInfo (var macFontInfo: FontInfo);
  2456.         function GetHeight (startLine, endLine: Longint): Longint;
  2457.         OVERRIDE;
  2458.         function GetCharOffset (aPt: LongPt): Longint;
  2459.         OVERRIDE;
  2460.         procedure GetCharPoint (theOffset: Longint; var aPt: LongPt);
  2461.         OVERRIDE;
  2462.         procedure GetTextStyle (var whichAttributes: Integer; var aStyle: TextStyle);
  2463.         OVERRIDE;
  2464.         procedure GetCharStyle (charOffset: Longint; var theStyle: TextStyle);
  2465.         OVERRIDE;
  2466.         function GetSpacingCmd: Longint;
  2467.         OVERRIDE;
  2468.         function GetAlignCmd: Longint;
  2469.         OVERRIDE;
  2470.         function GetNumLines: Longint;
  2471.         OVERRIDE;
  2472.         procedure GetSelection (var selStart, selEnd: Longint);
  2473.         OVERRIDE;
  2474.         procedure AboutToPrint (var firstPage, lastPage: Integer);
  2475.         OVERRIDE;
  2476.         procedure PrintPage (pageNum: Integer; pageWidth, pageHeight: Integer; aPrinter: CPrinter);
  2477.         OVERRIDE;
  2478.         procedure DonePrinting;
  2479.         OVERRIDE;
  2480.         procedure Dawdle (var maxSleep: Longint);
  2481.         OVERRIDE;
  2482.     end;
  2483.  
  2484.  
  2485. const
  2486.  
  2487. kMaxTELength = 32000;        { maximum text we allow in TE record   }
  2488.  
  2489. {****************************************************************************}
  2490. { CTextEditTask}
  2491. { }
  2492. {****************************************************************************}
  2493.  
  2494. { saves information about a range of text}
  2495. type
  2496. tTextRange = record
  2497.         text: Handle;
  2498.         startPos: Longint;
  2499.         endPos: Longint;
  2500.         selStart: Longint;
  2501.         selEnd: Longint;
  2502.     end;
  2503.  
  2504. { specify either insert or deleted range of text}
  2505.  
  2506. tRangeSelector = (kInsertedRange, kDeletedRange);
  2507.  
  2508. { specify either the old or new clipboard}
  2509.  
  2510. tClipSelector = (kOldClip, kNewClip);
  2511.  
  2512.  
  2513. CTextEditTask = object(CTask)
  2514.  
  2515.         itsTextPane: CAbstractText;        { Target text pane for this task}
  2516.         editCmd: Longint;                { initiating command, cmdNull for typing}
  2517.         inserted: tTextRange;            { info about the inserted text}
  2518.         deleted: tTextRange;            { info about the deleted text}
  2519.         originalScrap: Handle;            { contents of text scrap, before the task}
  2520.         stillTyping: Boolean;            { true if typing is active}
  2521.         doText: Boolean;                { TRUE if text should be undone}
  2522.         doClip: Boolean;                { TRUE if clipboard should be undone}
  2523.         typingEvent: EventRecord;        { event record for last keystroke}
  2524.  
  2525.         procedure ITextEditTask (aTextPane: CAbstractText; anEditCmd: Longint; firstTaskIndex: Integer);
  2526.         procedure DoTask;
  2527.         OVERRIDE;
  2528.         procedure DoTyping (theChar: Char; keyCode: Integer; VAR macEvent: EventRecord);
  2529.         procedure Undo;
  2530.         OVERRIDE;
  2531.         procedure Redo;
  2532.         OVERRIDE;
  2533.         procedure Free;
  2534.         OVERRIDE;
  2535.         procedure CancelTyping;
  2536.         procedure SelectionChanged;
  2537.         function CanStillType: Boolean;
  2538.         procedure DoNormalChar (theChar: Char);
  2539.         procedure DoBackspace;
  2540.         procedure DoFwdDelete;
  2541.         procedure SaveRange (whichRange: tRangeSelector);
  2542.         procedure DeleteRange (whichRange: tRangeSelector);
  2543.         procedure RestoreRange (whichRange: tRangeSelector; killData: Boolean);
  2544.         procedure StoreToClip (whichClip: tClipSelector);
  2545.     end;
  2546.  
  2547. {****************************************************************************}
  2548. { CTextStyleTask    }
  2549. {}
  2550. {****************************************************************************}
  2551.  
  2552. type
  2553. CTextStyleTask = object(CTask)
  2554.  
  2555.         itsTextPane: CAbstractText;        { target text pane                    }
  2556.         oldStyle: TextStyle;            { original style before command    }
  2557.         oldAlignCmd: Longint;            { original alignment before command}
  2558.         oldSpacingCmd: Longint;            { original spacing before command    }
  2559.         styleCmd: Longint;                { command that initiated this task    }
  2560.         styleAttribute: Integer;        { style attributes affected by this task}
  2561.  
  2562.         procedure ITextStyleTask (aTextPane: CAbstractText; aStyleCmd: Longint; taskIndex: Integer);
  2563.         procedure Free;
  2564.         OVERRIDE;
  2565.         procedure DoTask;
  2566.         OVERRIDE;
  2567.         procedure Undo;
  2568.         OVERRIDE;
  2569.         procedure SaveStyle;
  2570.         procedure RestoreStyle;
  2571.     end;
  2572.  
  2573. const
  2574.  
  2575.     { style modes used by CTextStyleTask in addition to those that}
  2576.     { are defined in TextEdit unit }
  2577.  
  2578. doAlign = 32;        { change text alignment}
  2579. doSpacing = 64;        { change line spacing}
  2580.  
  2581.  
  2582. {****************************************************************************}
  2583. { CFile}
  2584. {        }
  2585. {    TCL 1.1 CHANGES}
  2586. {    [}
  2587. {        - changed interface of all methods returning OSErr to void. These}
  2588. {            methods now use the exception mechanism to report failure. If}
  2589. {            you need or prefer the old interface, use the compatibility}
  2590. {            class BFile.}
  2591. {        - added ExistsOnDisk, GetMacFileInfo, SpecifyFSSpec, GetFSSpec,}
  2592. {          and ResolveFileAlias methods}
  2593. {    ]}
  2594. {    }
  2595. {****************************************************************************}
  2596.  
  2597. type
  2598. CFile = object(CObject)
  2599.  
  2600.         name: Str255;
  2601.         volNum: Integer;
  2602.         dirID: Longint;
  2603.  
  2604.         procedure IFile;
  2605.         procedure Free;
  2606.         OVERRIDE;
  2607.         procedure Specify (aName: Str255; aVolNum: Integer);
  2608.         procedure SpecifyHFS (aName: Str255; aVolNum: Integer; aDirID: Longint);
  2609.         procedure SFSpecify (macSFReply: SFReply);
  2610.         procedure SpecifyFSSpec (aFileSpec: FSSpec);
  2611.         procedure ResolveFileAlias;
  2612.         procedure Open (permission: SignedByte);
  2613.         procedure Close;
  2614.         function ExistsOnDisk: Boolean;
  2615.         procedure GetName (var theName: Str255);
  2616.         procedure GetMacFileInfo (var fileInfo: FInfo);
  2617.         procedure GetFSSpec (var aFileSpec: FSSpec);
  2618.         procedure CreateNew (creator: OSType; fType: OSType);
  2619.         procedure ThrowOut;
  2620.         procedure ChangeName (newName: Str255);
  2621.     end;
  2622.  
  2623.  
  2624. {****************************************************************************}
  2625. { CDataFile}
  2626. {}
  2627. {    TCL 1.1 CHANGES}
  2628. {    [}
  2629. {        -     changed interface of all methods returning OSErr. Most }
  2630. {            now return void, except GetLength, GetMark, and ReadAll.}
  2631. {            All methods now use the exception mechanism to report failure.}
  2632. {            If you need or prefer the old interface, use the compatibility}
  2633. {            class ODataFile.}
  2634. {    ]}
  2635. {}
  2636. {****************************************************************************}
  2637.  
  2638. type
  2639. CDataFile = object(CFile)
  2640.  
  2641.         refNum: Integer;
  2642.  
  2643.         procedure IDataFile;
  2644.         procedure SetLength (aLength: Longint);
  2645.         function GetLength: Longint;
  2646.         procedure SetMark (howFar: Longint; fromWhere: Integer);
  2647.         function GetMark: Longint;
  2648.         procedure Open (permission: SignedByte);
  2649.         OVERRIDE;
  2650.         procedure Close;
  2651.         OVERRIDE;
  2652.         function ReadAll: Handle;
  2653.         procedure ReadSome (info: univ Ptr; howMuch: Longint);
  2654.         procedure WriteAll (contents: univ Handle);
  2655.         procedure WriteSome (info: univ Ptr; howMuch: Longint);
  2656.     end;
  2657.  
  2658.  
  2659. {**************************************************}
  2660. { GlobalVars}
  2661. {}
  2662. {        Global Variables for the THINK Class Library}
  2663. {}
  2664. {**************************************************}
  2665.  
  2666. var
  2667. gApplication: CApplication;            { Application object                }
  2668. gDesktop: CDesktop;                    { The visible Desktop                }
  2669. gBartender: CBartender;                { Manages all menus                    }
  2670. gClipboard: CClipboard;                { Copies and Pastes data            }
  2671. gGopher: CBureaucrat;                { First in line to get commands        }
  2672. gError: CError;                        { Error handler                        }
  2673. gDecorator: CDecorator;                { Decorator for arranging windows    }
  2674. gSleepTime: longint;                { MultiFinder thingy                }
  2675. gHasWNE: Boolean;                    { Is WaitNextEvent implemented?    }
  2676. gInBackground: Boolean;                { In background under MultiFinder    }
  2677. gSignature: OSType;                    { Creator for Application's files    }
  2678. gLastMouseDown: EventRecord;        { Previous mousedown event             }
  2679. gLastMouseUp: EventRecord;            { Previous mouseup event            }
  2680. gLastViewHit: CView;                { Last view clicked in                }
  2681. gClicks: integer;                    { Click counter; = 1 single click,     }
  2682.                                     {                   = 2 double click    ,}
  2683.                                     {                   etc.                }
  2684. gIBeamCursor: CursHandle;            { I-beam for text views                }
  2685. gWatchCursor: CursHandle;            { Watch cursor for waiting            }
  2686. gUtilRgn: RgnHandle;                { Utility region                     }
  2687.  
  2688. {**************************************************}
  2689. { Utilities}
  2690. {}
  2691. {        Utility routines used by the THINK Class Library.}
  2692. {        These routines are defined in the implementation section (below)}
  2693. {}
  2694. {**************************************************}
  2695.  
  2696.                                         { Operating System utilities }
  2697.  
  2698. function TrapAvailable (theTrap: integer): Boolean; EXTERNAL;
  2699. function WNEIsImplemented: Boolean;
  2700. function TempMemCallsAvailable: Boolean;
  2701. function ColorQDIsPresent: Boolean;
  2702. procedure FlushCache;    { TCL 1.1.1 DLP 9/26/91 }
  2703.  
  2704.                                         { Window Manager utilities    }
  2705.  
  2706. function IsSystemWindow (macWindow: WindowPeek): Boolean;
  2707. function IsMyWindow (macWindow: WindowPeek): Boolean;
  2708. procedure BringBehind (macWindow, behindWindow: WindowPtr);
  2709.  
  2710.                                         { Dialog Manager utilities        }
  2711.  
  2712. function IsDialogWindow (macWindow: WindowPeek): Boolean;
  2713. procedure PositionDialog (theType: ResType; theID: integer);
  2714. procedure FindDlogPosition (theType: ResType; theID: integer; var corner: Point);
  2715.  
  2716.                                         { Font utility                    }
  2717.  
  2718. procedure GetFontNumber (fontName: Str255; var fontNum: integer);
  2719.  
  2720.                                         { Keyboard utility             }
  2721.  
  2722. function KeyIsDown (theKeyCode: integer): Boolean;
  2723.  
  2724.                                         { QuickDraw utilities         }
  2725.  
  2726. procedure DrawSICN (SICNid, index: integer; location: Point);
  2727. procedure PinInRect (theRect: LongRect; var thePoint: LongPt);
  2728.  
  2729. procedure SetHiliteMode;
  2730. {$IFC MAC68K}
  2731. inline
  2732. $08B8, $0007, $0938;  { bclr #7 , 0x938 (HiliteMode) }
  2733. {$ENDC}
  2734.  
  2735.                                         { other utilities                }
  2736.  
  2737. function HiByte (shortNum: integer): integer;
  2738. function LoByte (shortNum: integer): integer;
  2739. function topLeft (aRect: Rect): Point;
  2740. function Max (val1, val2: longint): longint;
  2741. function Min (val1, val2: longint): longint;
  2742. function MenuEnabled (macMenu: MenuHandle): Boolean;
  2743. function GrowZoneFunc (bytesNeeded: Size): longint;
  2744. procedure CheckResource (r: Handle);
  2745. procedure CheckAllocation (p: Ptr);
  2746. procedure CountClicks (hitView: CView; var macEvent: EventRecord);
  2747.  
  2748.  
  2749. implementation
  2750.  
  2751. uses
  2752.     Script, LowMem, Traps;
  2753.  
  2754.  
  2755.  
  2756. {$IFC POWERPC}
  2757. procedure CallTheThumbFunc (theScrollBar: CScrollBar; delta: integer; thumbFunc: ControlActionUPP);
  2758. const
  2759.     TheThumbFunc = $000002C0; { PROCEDURE (4 byte param, 2 byte param); }
  2760. begin
  2761.     if CallUniversalProc(thumbFunc, TheThumbFunc, theScrollBar, delta) <> 0 then ;
  2762. end;
  2763.  
  2764. procedure SetHiliteMode;
  2765. begin
  2766.     LMSetHiliteMode(0);
  2767. end;
  2768. {$ENDC}
  2769.  
  2770. {    Operating System utilities    }
  2771.  
  2772. {**************************************************}
  2773.  { FlushCache         TCL 1.1.1 DLP 9/26/91 }
  2774.  { Clear the CPU cache. This is required on 68040 machines   }
  2775.  { after modifying code in memory, e.g. when setting up          }
  2776.  { a stub code resource for CMenuDefProc                             }
  2777. {**************************************************}
  2778.  
  2779. {$IFC MAC68K}
  2780. procedure CallCacheFlush;
  2781. inline
  2782.     $A0BD;
  2783.  
  2784. procedure FlushCache;    { TCL 1.1.1 DLP 9/26/91 }
  2785.     const
  2786.         _CacheFlushTrap = $A0BD;
  2787.     begin
  2788.         if TrapAvailable(_CacheFlushTrap) then
  2789.             CallCacheFlush;
  2790.     end;
  2791. {$ENDC}
  2792.  
  2793. {**************************************************}
  2794. { TrapAvailable}
  2795. {}
  2796. {     Check whether a certain trap exists on this machine.  }
  2797. { this function uses the new approved method as per IM-VI}
  2798. {    p. 3-8                                                }
  2799. {}
  2800. {**************************************************}
  2801.  
  2802. function TrapAvailable (theTrap: Integer): Boolean;
  2803.     var
  2804.         UPPForTheUNIMPLEMENTEDProcedure: UniversalProcPtr;
  2805.         UPPForTheTrap: UniversalProcPtr;
  2806.     begin
  2807.  
  2808.         UPPForTheTrap := GetOSTrapAddress(theTrap);
  2809.         UPPForTheUNIMPLEMENTEDProcedure:= GetOSTrapAddress(_Unimplemented);
  2810.         TrapAvailable:= UPPForTheTrap <> UPPForTheUNIMPLEMENTEDProcedure;
  2811.     end;
  2812.  
  2813. (*
  2814. function TrapAvailable (theTrap: Integer): Boolean;
  2815.     var
  2816.         tType: TrapType;
  2817.         numToolBoxTraps: Integer;
  2818.  
  2819.     begin
  2820.  
  2821.          { first determine the trap type }
  2822.  
  2823.         if BAND(theTrap, $0800) > 0 then
  2824.             tType := ToolTrap
  2825.         else
  2826.             tType := OSTrap;
  2827.  
  2828.          { next find out how may traps there are }
  2829.  
  2830.         if NGetTrapAddress(_InitGraf, ToolTrap) = NGetTrapAddress($AA6E, ToolTrap) then
  2831.             numToolBoxTraps := $200
  2832.         else
  2833.             numToolBoxTraps := $400;
  2834.  
  2835.          { check if trap number is too big for current trap table }
  2836.  
  2837.         if tType = ToolTrap then
  2838.             begin
  2839.                 theTrap := BAND(theTrap, $07FF);
  2840.                 if theTrap >= numToolBoxTraps then
  2841.                     theTrap := _Unimplemented;
  2842.             end;
  2843.  
  2844.          { the trap is implemented if its address is different     }
  2845.          { from the unimplemented trap's address                }
  2846.  
  2847.         TrapAvailable := NGetTrapAddress(theTrap, tType) <> NGetTrapAddress(_Unimplemented, ToolTrap);
  2848.  
  2849.     end;
  2850. *)
  2851.  
  2852. {**************************************************}
  2853. { WNEIsImplemented}
  2854. {}
  2855. {     See if WaitNextEvent is implemented }
  2856. {}
  2857. {**************************************************}
  2858.  
  2859. function WNEIsImplemented: Boolean;
  2860.  
  2861.     const
  2862.         _WaitNextEvent = $A860;                    { WaitNextEvent trap                    }
  2863.  
  2864.     var
  2865.         theWorld: SysEnvRec;                        { System environment                }
  2866.         errCode: OSErr;
  2867.  
  2868.     begin
  2869.         errCode := SysEnvirons(1, theWorld);        { Check environment                    }
  2870.  
  2871.         if theWorld.machineType < 0 then             { Old ROMs, definitely not present    }
  2872.             WNEIsImplemented := FALSE
  2873.  
  2874.         else                                            { Check for WNE trap                    }
  2875.  
  2876.             WNEIsImplemented := TrapAvailable(_WaitNextEvent)
  2877.  
  2878.     end;
  2879.  
  2880.  
  2881. {**************************************************}
  2882. { TempMemCallsAvailable}
  2883. {}
  2884. {     Check whether the MultiFinder temporary memory calls are available}
  2885. {}
  2886. {**************************************************}
  2887.  
  2888. function TempMemCallsAvailable: Boolean;
  2889.  
  2890.     const
  2891.         _OSDispatch = $A88F;                        { Temporary MF memory calls        }
  2892.  
  2893.     begin
  2894.  
  2895.                         { Check for the OSDispatch trap    }
  2896.  
  2897.         TempMemCallsAvailable := TrapAvailable(_OSDispatch);
  2898.     end;
  2899.  
  2900.  
  2901. {**************************************************}
  2902. { ColorQDIsPresent}
  2903. {}
  2904. {     Check whether Color QuickDraw is present}
  2905. {}
  2906. {**************************************************}
  2907.  
  2908. function ColorQDIsPresent: Boolean;
  2909.  
  2910.     var
  2911.         theWorld: SysEnvRec;                            { System environment            }
  2912.         errCode: OSErr;
  2913.  
  2914.     begin
  2915.         errCode := SysEnvirons(1, theWorld);            { Check environment                }
  2916.         ColorQDIsPresent := theWorld.hasColorQD;    { Return environment field        }
  2917.     end;
  2918.  
  2919.  
  2920. {    Window Manager utilities    }
  2921.  
  2922.  
  2923. {**************************************************}
  2924. { IsSystemWindow}
  2925. {}
  2926. {        Determine if the window belongs to a DA}
  2927. {}
  2928. {**************************************************}
  2929.  
  2930. function IsSystemWindow (macWindow: WindowPeek): Boolean;
  2931.  
  2932.     begin
  2933.  
  2934.         { System windows (DAs) have a negative windowKind }
  2935.  
  2936.         if macWindow <> nil then
  2937.             IsSystemWindow := macWindow^.windowKind < 0
  2938.         else
  2939.             IsSystemWindow := FALSE;
  2940.     end;
  2941.  
  2942.  
  2943. {**************************************************}
  2944. { IsMyWindow}
  2945. {}
  2946. {        Check whether a window is an application window}
  2947. {}
  2948. {**************************************************}
  2949.  
  2950. function IsMyWindow (macWindow: WindowPeek): Boolean;
  2951.  
  2952.     var
  2953.         wKind: integer;
  2954.  
  2955.     begin
  2956.  
  2957.         { All application windows have a kind >= userKind    }
  2958.  
  2959.         if macWindow <> nil then
  2960.             begin
  2961.                 wKind := macWindow^.windowKind;
  2962.                 IsMyWindow := ((wKind >= userKind) and (wKind < pascalKind)) or (wKind = dialogKind);
  2963.             end
  2964.         else
  2965.             IsMyWindow := FALSE;
  2966.     end;
  2967.  
  2968.  
  2969. {**************************************************}
  2970. { BringBehind}
  2971. {}
  2972. {        Move a window from far back to right behind another window}
  2973. {}
  2974. {**************************************************}
  2975.  
  2976. procedure BringBehind (macWindow, behindWindow: WindowPtr);
  2977.  
  2978.     var
  2979.         savePort: GrafPtr;        { Current port                    }
  2980.         corner: Point;            { Top left of visible region    }
  2981.  
  2982.     begin
  2983.         GetPort(savePort);        { Save current port                }
  2984.         SetPort(macWindow);    { Use this window's port            }
  2985.  
  2986.             { Save portion of window which is originally visible}
  2987.  
  2988.         CopyRgn(macWindow^.visRgn, gUtilRgn);
  2989.  
  2990.             { Adjust the window's plane        }
  2991.  
  2992.         SendBehind(macWindow, behindWindow);
  2993.  
  2994.             { We must draw the newly exposed portion of the window.  Find the    }
  2995.             { difference between the present structure region and what was        }
  2996.             { originally visible.  Before doing this, we must convert the         }
  2997.             { originally visible region to global coords.                           }
  2998.  
  2999.         corner := gUtilRgn^^.rgnBBox.topLeft;
  3000.         LocalToGlobal(corner);
  3001.         OffsetRgn(gUtilRgn, (corner.h - gUtilRgn^^.rgnBBox.left), (corner.v - gUtilRgn^^.rgnBBox.top));
  3002.  
  3003.             { Now we can difference the regions.  Save space by putting the    }
  3004.             { result back in theRgn.  Before calling DiffRgn, gUtilRgn is the     }
  3005.             { originally visible region.  Afterwards, gUtilRgn is the newly    }
  3006.             { exposed region of the window.                                         }
  3007.  
  3008.         DiffRgn(WindowPeek(macWindow)^.strucRgn, gUtilRgn, gUtilRgn);
  3009.  
  3010.             { Draw newly exposed region        }
  3011.  
  3012.         PaintOne(WindowRef(macWindow), gUtilRgn);
  3013.  
  3014.             { Since window has moved forward, we must adjust the visible    }
  3015.             {   regions of this window and those behind it.                    }
  3016.  
  3017.         CalcVisBehind(WindowRef(macWindow), (WindowPeek(macWindow)^.strucRgn));
  3018.  
  3019.             { Restore the original port        }
  3020.  
  3021.         SetPort(savePort);
  3022.     end;
  3023.  
  3024.  
  3025. {    Dialog Manager utilities    }
  3026.  
  3027.  
  3028. {**************************************************}
  3029. { IsDialogWindow}
  3030. {}
  3031. {        Determine if the window is a dialog box}
  3032. {}
  3033. {**************************************************}
  3034.  
  3035. function IsDialogWindow (macWindow: WindowPeek): Boolean;
  3036.  
  3037.     begin
  3038.  
  3039.         { Dialog boxes have a windowKind of dialogKind }
  3040.  
  3041.         if macWindow <> nil then
  3042.             IsDialogWindow := macWindow^.windowKind = dialogKind
  3043.         else
  3044.             IsDialogWindow := FALSE;
  3045.  
  3046.     end;
  3047.  
  3048.  
  3049. {**************************************************}
  3050. { PositionDialog}
  3051. {}
  3052. {        Center the bounding box of a dialog or alert in the upper third}
  3053. {        of the screen.  This is the preferred location according to the}
  3054. {        Human Interface Guidelines.}
  3055. {}
  3056. {**************************************************}
  3057.  
  3058. procedure PositionDialog (theType: ResType; theID: integer);
  3059.  
  3060.     var
  3061.         theRect: Rect;
  3062.         theRectPtr: RectPtr;        { Ptr to bounding box of dialog    }
  3063.         theTemplate: Handle;        { Handle to resource template    }
  3064.         left,                            { Left side of centered rect        }
  3065.         top: integer;                { Top side of centered rect        }
  3066.  
  3067.     begin
  3068.  
  3069.         { The first field of the resource template for DLOG's and ALRT's     }
  3070.         { is its bounding box.  Get a pointer to this rectangle.  This               }
  3071.         { handle dereferencing is safe since the remaining statements in     }
  3072.         { this function do not move memory (assignment and simple math).     }
  3073.  
  3074.         theTemplate := GetResource(theType, theID);
  3075.         FailNILRes(theTemplate);
  3076.         theRectPtr := RectPtr(theTemplate^);
  3077.         theRect := theRectPtr^;
  3078.  
  3079.         { Center horizontally on screen    }
  3080.  
  3081.         left := (qd.screenBits.bounds.right - (theRect.right - theRect.left)) div 2;
  3082.  
  3083.         { Leave twice as much space as above     }
  3084.  
  3085.         top := (qd.screenBits.bounds.bottom - (theRect.bottom - theRect.top)) div 3;
  3086.  
  3087.         { Don't put rect under menu bar    }
  3088.  
  3089.         if top < GetMBarHeight + 7 then
  3090.             top := GetMBarHeight + 7;
  3091.  
  3092.         theRect.right := theRect.right + left - theRect.left;
  3093.         theRect.left := left;
  3094.         theRect.bottom := theRect.bottom + top - theRect.top;
  3095.         theRect.top := top;
  3096.  
  3097.         theRectPtr^ := theRect;
  3098.     end;
  3099.  
  3100.  
  3101. {**************************************************}
  3102. { FindDlogPosition}
  3103. {}
  3104. {         Return the coordinates of the top left corner of a dialog or alert}
  3105. {         which centers the box in the upper third of the main screen. This is}
  3106. {         the preferred location according to the Human Interface Guidelines.}
  3107. {}
  3108. {**************************************************}
  3109.  
  3110. procedure FindDlogPosition (theType: ResType; theID: integer; var corner: Point);
  3111.  
  3112.     var
  3113.         theRect: Rect;        { Bounding box of dialog                }
  3114.         left, top: integer;    { Left, top side of centered rect        }
  3115.  
  3116.     begin
  3117.  
  3118.         { The first field of the resource template for DLOG's and ALRT's     }
  3119.         { is its bounding box.  Access this rectangle.  This                       }
  3120.         { handle dereferencing is safe since the remaining statements in     }
  3121.         { this function do not move memory (assignment and simple math).     }
  3122.  
  3123.         theRect := RectHandle(GetResource(theType, theID))^^;
  3124.  
  3125.         { Center horizontally on screen    }
  3126.  
  3127.         corner.h := (qd.screenBits.bounds.right - (theRect.right - theRect.left)) div 2;
  3128.  
  3129.         { Leave twice as much space as above     }
  3130.  
  3131.         corner.v := (qd.screenBits.bounds.bottom - (theRect.bottom - theRect.top)) div 3;
  3132.  
  3133.         { Don't put rect under menu bar    }
  3134.  
  3135.         if corner.v < GetMBarHeight + 7 then
  3136.             corner.v := GetMBarHeight + 7;
  3137.     end;
  3138.  
  3139.  
  3140. {    Font utility    }
  3141.  
  3142.  
  3143. {**************************************************}
  3144. { GetFontNumber}
  3145. {}
  3146. {     Find font number given the font name.  If not found, a negative}
  3147. {     font number is returned.}
  3148. {}
  3149. {**************************************************}
  3150.  
  3151. procedure GetFontNumber (fontName: Str255; var fontNum: integer);
  3152.  
  3153.     var
  3154.         sysFontName: Str255;
  3155.  
  3156.     begin
  3157.         GetFNum(fontName, fontNum);            { Find corresponding font number    }
  3158.  
  3159.         if fontNum = systemFont then
  3160.             begin
  3161.  
  3162.             { fontNum is set to sysFont if fontName is not found.         }
  3163.             { We must check for the special case where the system     }
  3164.             { font is indeed being retrieved, by comparing the name    }
  3165.             { of the font with that of the system font.                    }
  3166.  
  3167.                 GetFontName(systemFont, sysFontName);
  3168.                 if not EqualString(fontName, sysFontName, FALSE, FALSE) then
  3169.  
  3170.                     fontNum := -1;                        { Font not found                        }
  3171.             end;
  3172.     end;
  3173.  
  3174.  
  3175. {    Keyboard utility    }
  3176.  
  3177.  
  3178. {**************************************************}
  3179. { KeyIsDown}
  3180. {}
  3181. {        Determine whether or not the specified key is being pressed. Keys}
  3182. {        are specified by hardware-specific key code (NOT the character).}
  3183. {}
  3184. {**************************************************}
  3185.  
  3186. function KeyIsDown (theKeyCode: integer): Boolean;
  3187.  
  3188.     var
  3189.         theKeys: KeyMap;
  3190.  
  3191.     begin
  3192.         GetKeys(theKeys);
  3193.         KeyIsDown := theKeys[theKeyCode];
  3194.     end;
  3195.  
  3196.  
  3197. {    Quickdraw utilities    }
  3198.  
  3199.  
  3200. {**************************************************}
  3201. { DrawSICN}
  3202. {}
  3203. {        Draw a SICN, a resource type which defines a 16 by 16 bit image,}
  3204. {        at the given location. SICN is specified by a resource ID number,}
  3205. {        and a one-based index into the SICN list.  The location specifies}
  3206. {        the top left corner of the SICN in the local coordinates of the }
  3207. {        current port.}
  3208. {}
  3209. {**************************************************}
  3210.  
  3211. procedure DrawSICN (SICNid: integer; index: integer; location: Point);
  3212.  
  3213.     var
  3214.         theSICN: Handle;
  3215.         theImage: BitMap;
  3216.         theBounds: Rect;
  3217.  
  3218.     begin
  3219.         theSICN := GetResource('SICN', SICNid);
  3220.         FailNILRes(theSICN);
  3221.  
  3222.         HLock(theSICN);
  3223.  
  3224. {             A SICN resource is really a list }
  3225. {               of small icons, each of which      }
  3226. {                has 32 bytes of data;               }
  3227. {                16 x 16 = 256 bits = 32 bytes    }
  3228. {                                                             }
  3229. {              Create a bitmap so we can copy     }
  3230. {                the SICN image on the screen       }
  3231. {                                                             }
  3232. {              Index into handle to get a ptr       }
  3233. {                to the SICN bit image                  }
  3234.  
  3235.         theImage.baseAddr := Ptr(LongPtr(theSICN)^ + (index - 1) * 32);
  3236.  
  3237.         theImage.rowBytes := 2;            { 16 bits is 2 bytes }
  3238.  
  3239.             { Place bitmap at desired location }
  3240.  
  3241.         SetRect(theBounds, location.h, location.v, location.h + 16, location.v + 16);
  3242.         theImage.bounds := theBounds;
  3243.  
  3244.             { Copy image onto the screen }
  3245.  
  3246.         CopyBits(theImage, qd.thePort^.portBits, theBounds, theBounds, srcCopy, nil);
  3247.  
  3248.         HUnlock(theSICN);
  3249.     end;
  3250.  
  3251.  
  3252. {**************************************************}
  3253. { PinInRect}
  3254. {}
  3255. {        Pin a point inside a rectangle. Similar to the PinRect Toolbox}
  3256. {        trap except that the point is changed in place and one (1) is not}
  3257. {        subtracted at the right and bottom edges.}
  3258. {}
  3259. {**************************************************}
  3260.  
  3261. procedure PinInRect (theRect: LongRect; var thePoint: LongPt);
  3262.  
  3263.     begin
  3264.         thePoint.h := Max(theRect.left, thePoint.h);
  3265.         thePoint.h := Min(theRect.right, thePoint.h);
  3266.         thePoint.v := Max(theRect.top, thePoint.v);
  3267.         thePoint.v := Min(theRect.bottom, thePoint.v);
  3268.     end;
  3269.  
  3270.  
  3271. {    Other utilities    }
  3272.  
  3273.  
  3274. {**************************************************}
  3275. {    HiByte}
  3276. {}
  3277. {        Return the high byte of an integer}
  3278. {}
  3279. {**************************************************}
  3280.  
  3281. function HiByte (shortNum: integer): integer;
  3282.  
  3283.     begin
  3284.         HiByte := BitAnd(BSR(shortNum, 8), $FF);
  3285.     end;
  3286.  
  3287.  
  3288. {**************************************************}
  3289. {    LoByte}
  3290. {}
  3291. {        Return the low byte of an integer}
  3292. {}
  3293. {**************************************************}
  3294.  
  3295. function LoByte (shortNum: integer): integer;
  3296.  
  3297.     begin
  3298.         LoByte := BitAnd(shortNum, $FF);
  3299.     end;
  3300.  
  3301.  
  3302. {**************************************************}
  3303. {    topLeft}
  3304. {}
  3305. {        Return the topLeft point of a rect}
  3306. {}
  3307. {**************************************************}
  3308.  
  3309. function topLeft (aRect: Rect): Point;
  3310.  
  3311.     begin
  3312.         topLeft := aRect.topLeft;
  3313.     end;
  3314.  
  3315.  
  3316. {**************************************************}
  3317. {    Max}
  3318. {}
  3319. {        Return the maximum of two values}
  3320. {}
  3321. {**************************************************}
  3322.  
  3323. function Max (val1, val2: longint): longint;
  3324.  
  3325.     begin
  3326.         if val1 < val2 then
  3327.             Max := val2
  3328.         else
  3329.             Max := val1
  3330.     end;
  3331.  
  3332.  
  3333. {**************************************************}
  3334. {    Min}
  3335. {}
  3336. {        Return the minimum of two values}
  3337. {}
  3338. {**************************************************}
  3339.  
  3340. function Min (val1, val2: longint): longint;
  3341.  
  3342.     begin
  3343.         if val1 < val2 then
  3344.             Min := val1
  3345.         else
  3346.             Min := val2
  3347.     end;
  3348.  
  3349.  
  3350. {**************************************************}
  3351. {    MenuEnabled}
  3352. {}
  3353. {        Determine whether or not the given menu is enabled}
  3354. {}
  3355. {**************************************************}
  3356.  
  3357. function MenuEnabled (macMenu: MenuHandle): Boolean;
  3358.  
  3359.     begin
  3360.         MenuEnabled := BAND(macMenu^^.enableFlags, 1) <> 0;
  3361.     end;
  3362.  
  3363.  
  3364. {**************************************************}
  3365. { GrowZoneFunc}
  3366. {}
  3367. {            Called by the System when a memory request can't be filled. Send }
  3368. {            GrowMemory message to the Application. The bracketing calls to }
  3369. {            the Toolbox traps SetCurrentA5 and SetA5 are required because we }
  3370. {            don't know if A5 is set up properly. See TechNotes 136 and 208. }
  3371. {}
  3372. {**************************************************}
  3373.  
  3374. function GrowZoneFunc (bytesNeeded: Size): longint;
  3375.  
  3376.     var
  3377.         result: longint;                { Success or failure code             }
  3378.         dontMove: Handle;            { Block which we must not move     }
  3379.         saveHState: SignedByte;    {Original attributes of dontMove     }
  3380.         oldA5, temp: longint;
  3381.  
  3382.     begin
  3383.         oldA5 := SetCurrentA5;
  3384.         dontMove := GZSaveHnd;
  3385.         if dontMove <> nil then
  3386.             begin
  3387.                 saveHState := HGetState(dontMove);
  3388.                 HLock(dontMove);
  3389.             end;
  3390.         result := gApplication.GrowMemory(bytesNeeded);
  3391.         if dontMove <> nil then
  3392.             HSetState(dontMove, saveHState);
  3393.         GrowZoneFunc := result;
  3394.         temp := SetA5(oldA5);
  3395.     end;
  3396.  
  3397.  
  3398. {**************************************************}
  3399. {     CheckResource }
  3400. {}
  3401. {            Check for a nil resource handle, which indicates that a resource }
  3402. {            could not be found or read into memory. If handle is nil, post }
  3403. {            a severe error alert. }
  3404. {}
  3405. {**************************************************}
  3406.  
  3407. procedure CheckResource (r: Handle);
  3408.  
  3409.     begin
  3410.         if r = nil then
  3411.             gError.SevereMacError(resNotFound);
  3412.     end;
  3413.  
  3414.  
  3415. {**************************************************}
  3416. {     CheckAllocation }
  3417. {}
  3418. {            Check for a nil pointer or handle, which indicates that a }
  3419. {            requested memory block could not be allocated. }
  3420. {}
  3421. {**************************************************}
  3422.  
  3423. procedure CheckAllocation (p: Ptr);
  3424.  
  3425.     begin
  3426.         if p = nil then
  3427.             gError.SevereMacError(MemError);
  3428.     end;
  3429.  
  3430.  
  3431. {**************************************************}
  3432. {     CountClicks }
  3433. {}
  3434. {            Check if mouse down event is part of a multiple click }
  3435. {}
  3436. {**************************************************}
  3437.  
  3438. procedure CountClicks (hitView: CView; var macEvent: EventRecord);
  3439.  
  3440.     begin
  3441.         if (hitView = gLastViewHit) & ((macEvent.when - gLastMouseUp.when) < GetDblTime) & (hitView.HitSamePart(gLastMouseDown.where, macEvent.where)) then
  3442.             gClicks := gClicks + 1
  3443.         else
  3444.             gClicks := 1;
  3445.         gLastViewHit := hitView;
  3446.     end;
  3447.  
  3448.  
  3449. {****************************************************************************}
  3450. { QDToLongPt}
  3451. { }
  3452. {     Convert a Point to a LongPt}
  3453. {****************************************************************************}
  3454. procedure QDToLongPt (srcPt: Point; var destPt: LongPt);
  3455.     begin
  3456.         destPt.h := srcPt.h;
  3457.         destPt.v := srcPt.v;
  3458.     end;
  3459.  
  3460. {****************************************************************************}
  3461. { LongToQDPt}
  3462. { }
  3463. {     Convert a LongPt to a Point. Values are clipped to 16 bits.}
  3464. {****************************************************************************}
  3465. procedure LongToQDPt (srcPt: LongPt; var destPt: Point);
  3466.  
  3467.     begin
  3468.         destPt.h := Min(Max(MININT, srcPt.h), MAXINT);
  3469.         destPt.v := Min(Max(MININT, srcPt.v), MAXINT);
  3470.  
  3471.     end;
  3472.  
  3473. {****************************************************************************}
  3474. { SetLongPt}
  3475. { }
  3476. {     Set the members of a LongPt. }
  3477. {****************************************************************************}
  3478. procedure SetLongPt (var pt: LongPt; h: Longint; v: Longint);
  3479.     begin
  3480.         pt.h := h;
  3481.         pt.v := v;
  3482.  
  3483.     end;
  3484.  
  3485. {****************************************************************************}
  3486. { AddLongPt}
  3487. { }
  3488. {     Adds srcPt and destPt, returns the result in destPt.}
  3489. {****************************************************************************}
  3490. procedure AddLongPt (srcPt: LongPt; var destPt: LongPt);
  3491.     begin
  3492.         destPt.h := destPt.h + srcPt.h;
  3493.         destPt.v := destPt.v + srcPt.v;
  3494.  
  3495.     end;
  3496.  
  3497. {****************************************************************************}
  3498. { SubLongPt}
  3499. { }
  3500. {     Subtracts srcPt from destPt, returns the result in destPt.}
  3501. {****************************************************************************}
  3502. procedure SubLongPt (srcPt: LongPt; var destPt: LongPt);
  3503.     begin
  3504.         destPt.h := destPt.h - srcPt.h;
  3505.         destPt.v := destPt.v - srcPt.v;
  3506.     end;
  3507.  
  3508. {****************************************************************************}
  3509. { EqualLongPt}
  3510. { }
  3511. {     Returns TRUE if two LongPts are equal.}
  3512. {****************************************************************************}
  3513. function EqualLongPt (pt1: LongPt; pt2: LongPt): Boolean;
  3514.     begin
  3515.         EqualLongPt := (pt1.h = pt2.h) and (pt1.v = pt2.v);
  3516.     end;
  3517.  
  3518. {****************************************************************************}
  3519. { PtInQDSpace}
  3520. { }
  3521. {     Returns TRUE if a LongPt is within the 16-bit QuickDraw coordinate space}
  3522. {****************************************************************************}
  3523. function PtInQDSpace (pt: LongPt): Boolean;
  3524.     begin
  3525.         PtInQDSpace := ((pt.h >= MININT) and (pt.h <= MAXINT) and (pt.v >= MININT) and (pt.v <= MAXINT));
  3526.     end;
  3527.  
  3528. {****************************************************************************}
  3529. { QDToLongRect}
  3530. { }
  3531. {     Convert a Rect to a LongRect}
  3532. {****************************************************************************}
  3533. procedure QDToLongRect (srcRect: Rect; var destRect: LongRect);
  3534.     begin
  3535.         destRect.left := srcRect.left;
  3536.         destRect.top := srcRect.top;
  3537.         destRect.right := srcRect.right;
  3538.         destRect.bottom := srcRect.bottom;
  3539.     end;
  3540.  
  3541. {****************************************************************************}
  3542. { LongToQDRect}
  3543. { }
  3544. {     Convert aLongRect to a Rect. Values are clipped to 16 bit QuickDraw space.}
  3545. {****************************************************************************}
  3546. procedure LongToQDRect (srcRect: LongRect; var destRect: Rect);
  3547.     begin
  3548.         destRect.left := Min(Max(MININT, srcRect.left), MAXINT);
  3549.         destRect.top := Min(Max(MININT, srcRect.top), MAXINT);
  3550.         destRect.right := Min(Max(MININT, srcRect.right), MAXINT);
  3551.         destRect.bottom := Min(Max(MININT, srcRect.bottom), MAXINT);
  3552.     end;
  3553.  
  3554. {****************************************************************************}
  3555. { SetLongRect}
  3556. { }
  3557. {     Fill in the members of a LongRect.}
  3558. {****************************************************************************}
  3559. procedure SetLongRect (var r: LongRect; left: Longint; top: Longint; right: Longint; bottom: Longint);
  3560.     begin
  3561.         r.left := left;
  3562.         r.right := right;
  3563.         r.top := top;
  3564.         r.bottom := bottom;
  3565.     end;
  3566.  
  3567. {****************************************************************************}
  3568. { OffsetLongRect}
  3569. { }
  3570. {     Translates a LongRect. Positive values are to the right and down.}
  3571. {****************************************************************************}
  3572. procedure OffsetLongRect (var r: LongRect; dh: Longint; dv: Longint);
  3573.     begin
  3574.         r.left := r.left + dh;
  3575.         r.right := r.right + dh;
  3576.         r.top := r.top + dv;
  3577.         r.bottom := r.bottom + dv;
  3578.     end;
  3579.  
  3580. {****************************************************************************}
  3581. { InsetLongRect}
  3582. { }
  3583. {     Insets the sides of a LongRect. Positive values move the sizes inward.}
  3584. {****************************************************************************}
  3585. procedure InsetLongRect (var r: LongRect; dh: Longint; dv: Longint);
  3586.     begin
  3587.         r.left := r.left + dh;
  3588.         r.right := r.right - dh;
  3589.         r.top := r.top + dv;
  3590.         r.bottom := r.bottom - dv;
  3591.     end;
  3592.  
  3593. {****************************************************************************}
  3594. { SectLongRect}
  3595. { }
  3596. {     Calculates the intersection of two LongRects and returns the result}
  3597. {     in destRect. destRect may be the same as either src1 or src2. Returns TRUE}
  3598. {     if the result is non-empty.}
  3599. {****************************************************************************}
  3600. function SectLongRect (src1: LongRect; src2: LongRect; var destRect: LongRect): Boolean;
  3601.  
  3602.     begin
  3603.         destRect.left := Max(src1.left, src2.left);
  3604.         destRect.right := Min(src1.right, src2.right);
  3605.         destRect.top := Max(src1.top, src2.top);
  3606.         destRect.bottom := Min(src1.bottom, src2.bottom);
  3607.         SectLongRect := not EmptyLongRect(destRect);
  3608.     end;
  3609.  
  3610. {****************************************************************************}
  3611. { UnionLongRect}
  3612. { }
  3613. {    Calculates the union of two LongRects and returns the result}
  3614. {     in destRect. destRect may be the same as either src1 or src2.}
  3615. {****************************************************************************}
  3616. procedure UnionLongRect (src1: LongRect; src2: LongRect; var destRect: LongRect);
  3617.     begin
  3618.         destRect.left := Min(src1.left, src2.left);
  3619.         destRect.right := Max(src1.right, src2.right);
  3620.         destRect.top := Min(src1.top, src2.top);
  3621.         destRect.bottom := Max(src1.bottom, src2.bottom);
  3622.     end;
  3623.  
  3624. {****************************************************************************}
  3625. { PtInLongRect}
  3626. { }
  3627. {     Returns TRUE if pt lies within r.}
  3628. {****************************************************************************}
  3629. function PtInLongRect (pt: LongPt; r: LongRect): Boolean;
  3630.     begin
  3631.         PtInLongRect := ((pt.h >= r.left) and (pt.h < r.right) and (pt.v >= r.top) and (pt.v < r.bottom));
  3632.     end;
  3633.  
  3634. {****************************************************************************}
  3635. { Pt2LongRect}
  3636. { }
  3637. {     Calculates the minimal rect enclosing the two given points.}
  3638. {****************************************************************************}
  3639. procedure Pt2LongRect (pt1: LongPt; pt2: LongPt; var r: LongRect);
  3640.     begin
  3641.         r.left := Min(pt1.h, pt2.h);
  3642.         r.top := Min(pt1.v, pt2.v);
  3643.         r.right := Max(pt1.h, pt2.h);
  3644.         r.bottom := Max(pt1.v, pt2.v);
  3645.     end;
  3646.  
  3647. {****************************************************************************}
  3648. { EqualLongRect}
  3649. { }
  3650. {     Returns true if r1 and r2 are equal.}
  3651. {****************************************************************************}
  3652. function EqualLongRect (r1: LongRect; r2: LongRect): Boolean;
  3653.     begin
  3654.         EqualLongRect := EqualLongPt(r1.topLeft, r2.topLeft) & EqualLongPt(r1.botRight, r2.botRight);
  3655.     end;
  3656.  
  3657. {****************************************************************************}
  3658. { EmptyLongRect}
  3659. { }
  3660. {     Returns TRUE if r encloses no points.}
  3661. {****************************************************************************}
  3662. function EmptyLongRect (r: LongRect): Boolean;
  3663.     begin
  3664.         EmptyLongRect := ((r.top >= r.bottom) or (r.left >= r.right));
  3665.  
  3666.     end;
  3667.  
  3668. {****************************************************************************}
  3669. { RectInQDSpace}
  3670. { }
  3671. {     Returns TRUE if r is entirely within QD space.}
  3672. {****************************************************************************}
  3673. function RectInQDSpace (r: LongRect): Boolean;
  3674.     begin
  3675.         RectInQDSpace := PtInQDSpace(r.topLeft) & PtInQDSpace(r.botRight);
  3676.     end;
  3677.  
  3678. {****************************************************************************}
  3679. { AbortInQueue}
  3680. { }
  3681. {     Walk the event queue, return TRUE if a Command-'.' is there. The}
  3682. {     event is removed from the queue.}
  3683. {     }
  3684. {****************************************************************************}
  3685. function AbortInQueue: Boolean;    { TCL 1.1.1 DLP 9/25/91 }
  3686.     type
  3687.         EventRecordPtr = ^EventRecord;
  3688.     var
  3689.         qEvt: EvQElPtr;
  3690.         foundAbort: Boolean;
  3691.     begin
  3692.         foundAbort := FALSE;
  3693.         qEvt := EvQElPtr(GetEvQHdr^.qHead);
  3694.         while qEvt <> nil do
  3695.             begin
  3696.                 if IsCancelEvent(EventRecordPtr(@qEvt^.evtQWhat)^) then
  3697.                     begin
  3698.  
  3699.                         { Flush all keydown events from the event queue }
  3700.                         { This will get rid of the abort as well as     }
  3701.                         { any other pending keydowns                     }
  3702.  
  3703.                         FailOSErr(Dequeue(QElemPtr(qEvt), GetEvQHdr));
  3704.                         foundAbort := TRUE;
  3705.                         LEAVE;
  3706.                     end;
  3707.                 qEvt := EvQElPtr(qEvt^.qLink);
  3708.             end;
  3709.         AbortInQueue := foundAbort;
  3710.     end;
  3711.  
  3712. function IsCancelEvent (VAR theEvent: EventRecord): Boolean;
  3713.     const
  3714.  
  3715.         kMaskModifiers = $FE00;     { we need the modifiers without the     }
  3716.                                        { command key for KeyTrans                }
  3717.         kUpKeyMask = $0080;
  3718.         kMaskASCII1 = $00FF0000;     { get the key out of the ASCII1 byte     }
  3719.         kMaskASCII2 = $000000FF;     { get the key out of the ASCII2 byte     }
  3720.     var
  3721.         isCancel: Boolean;
  3722.         keyCode: Integer;
  3723.         virtualKey, keyInfo, lowChar, highChar, state, keyCId: Longint;
  3724.         hKCHR: Handle;
  3725.         KCHRPtr: Ptr;
  3726.     begin
  3727.         isCancel := FALSE;
  3728.         hKCHR := nil;
  3729.  
  3730.         if (theEvent.what = keyDown) | (theEvent.what = autoKey) then
  3731.             begin
  3732.  
  3733.         { see if the command key is down.  If it is, find out the ASCII     }
  3734.           { equivalent for the accompanying key.                                }
  3735.  
  3736.                 if BAND(theEvent.modifiers, cmdKey) <> 0 then
  3737.                     begin
  3738.                 { get virtual key and keycode for KeyTrans }
  3739.  
  3740.                         virtualKey := BSR(BAND(theEvent.message, keyCodeMask), 8);
  3741.  
  3742.                 { and out the command key and or in the virtualKey }
  3743.  
  3744.                         keyCode := BOR(BAND(theEvent.modifiers, kMaskModifiers), virtualKey);
  3745.  
  3746.                    { make it look like a keyup event, to prevent dead key processing }
  3747.  
  3748.                         keyCode := BOR(keyCode, kUpKeyMask);
  3749.  
  3750.                         KCHRPtr := Ptr(GetScriptManagerVariable(smKCHRCache));
  3751.  
  3752.                         if KCHRPtr = nil then
  3753.                             begin
  3754.                                 keyCId := GetScriptVariable(GetScriptManagerVariable(smKeyScript), smScriptKeys);
  3755.                                 hKCHR := GetResource('KCHR', keyCId);
  3756.                                 KCHRPtr := hKCHR^;
  3757.                             end;
  3758.  
  3759.                         if KCHRPtr <> nil then
  3760.                             begin
  3761.                                 state := 0;
  3762.                                 keyInfo := KeyTranslate(KCHRPtr, keyCode, state);
  3763.                                 if hKCHR <> nil then
  3764.                                     ReleaseResource(hKCHR);
  3765.                             end
  3766.                         else
  3767.                             keyInfo := theEvent.message;
  3768.  
  3769.                         lowChar := BAND(keyInfo, kMaskASCII2);
  3770.                         highChar := BSR(BAND(keyInfo, kMaskASCII1), 16);
  3771.                         if (lowChar = ord('.')) | (highChar = ord('.')) then
  3772.                             isCancel := true;
  3773.                     end;
  3774.             end;
  3775.  
  3776.         IsCancelEvent := isCancel;
  3777.     end;
  3778. {****************************************************************************}
  3779. { TCLUtilities}
  3780. {****************************************************************************}
  3781.  
  3782. {****************************************************************************}
  3783. { ErrorAlert}
  3784. { }
  3785. {     Displays an alert for the given error and message codes. The error message}
  3786. {     may be customized as follows:}
  3787. {     }
  3788. {     - If the low word of the message is non-zero, it is assumed to be}
  3789. {       the index of a string in a STR# resource.}
  3790. {       }
  3791. {        - if the high word of the message is zero, the STR# ID is the}
  3792. {          TCL's private STR# 301}
  3793. {          }
  3794. {        - if the high word is non-zero, it is taken as an offset from the}
  3795. {          base ID of 1024. For example, if the message is 2,563, or $0A03 hex,}
  3796. {          the high word is 10 decimal and low word is 3 decimal. Since the high}
  3797. {          word is non-zero it is added to 1024. The TCL will do a }
  3798. {          GetIndString( string, 1034, 3) to get the error string.}
  3799. {          }
  3800. {          The SpecifyMsg function in Exceptions.c will build the message longword}
  3801. {          for you. SpecifyMsg( 1034, 3) returns 2,563.}
  3802. {     }
  3803. {     - if the low word of the message is zero the TCL looks for an 'Estr' }
  3804. {       resource matching the error. If none is found, a generic error string }
  3805. {       is used.}
  3806. {     }
  3807. {****************************************************************************}
  3808. procedure ErrorAlert (error: Integer; message: Longint);
  3809.     var
  3810.         errStr: Str255;
  3811.         numStr: Str255;
  3812.         strIndex: Integer;
  3813.         strID: Integer;
  3814.         alertID: Integer;
  3815.         itemHit: Integer;
  3816.         strH: StringHandle;
  3817.  
  3818.     begin
  3819.         errStr := '';    { mark string empty }
  3820.  
  3821.     {)
  3822. {     *    First see if anyone filled in the}
  3823. {     *    message field}
  3824. {     }
  3825.                         { string index goes in low word of message }
  3826.         strIndex := LoWord(message);
  3827.         if (strIndex > 0) then
  3828.             begin
  3829.  
  3830.         { the STR# resource ID is either 131 or some value specified from    }
  3831.         { an implicit base value of 1024                                    }
  3832.  
  3833.                 strID := HiWord(message);
  3834.                 if (strID = 0) then
  3835.                     strID := STR_TCLfailMsgs
  3836.                 else
  3837.                     strID := strID + kUserFailMsgBase;
  3838.  
  3839.                 GetIndString(errStr, strID, strIndex);
  3840.             end;
  3841.  
  3842.         if Length(errStr) = 0 then
  3843.             begin
  3844.  
  3845.             {    Next, see if there is a custom 'Estr' resource for the error.     }
  3846.             {    If there isn't just get the default error string.                }
  3847.  
  3848.                 strH := StringHandle(GetResource(ErrMsg_Res, error));
  3849.                 if (strH = nil) then
  3850.                     strH := GetString(STRosError2);
  3851.                 if (strH <> nil) then
  3852.                     errStr := strH^^;
  3853.             end;
  3854.  
  3855.         NumToString(error, numStr);
  3856.         ParamText(errStr, numStr, '', '');
  3857.  
  3858.         if (gApplication = nil) | (gApplication.GetPhase <> appRunning) then
  3859.             alertID := ALRT_ExceptionAbort
  3860.         else
  3861.             alertID := ALRT_Exception;
  3862.  
  3863.             { avoid infinite recursion if the ALRT resource is missing by  }
  3864.             { testing for it here.                                            }
  3865.  
  3866.         if (GetResource('ALRT', alertID) = nil) | (GetResource('DITL', alertID) = nil) then
  3867.             begin
  3868.                 if gError <> nil then
  3869.                     gError.MissingResources
  3870.                 else
  3871.                     ExitToShell; { nothing else we can do... }
  3872.             end;
  3873.  
  3874.         PositionDialog('ALRT', alertID);
  3875.         InitCursor;
  3876.         itemHit := StopAlert(alertID, nil)
  3877.  
  3878.     end;
  3879.  
  3880. {****************************************************************************}
  3881. { NewHandleCanFail}
  3882. {}
  3883. {     Attempts to allocate a handle without drawing upon the memory reserve.}
  3884. {     Raises an exception if the allocation fails.}
  3885. {****************************************************************************}
  3886. function NewHandleCanFail (size: Longint): Handle;
  3887.     var
  3888.         h: Handle;
  3889.         savedAlloc: Boolean;
  3890.     begin
  3891.         savedAlloc := SetAllocation(kAllocCanFail);
  3892.         h := NewHandle(size);
  3893.         savedAlloc := SetAllocation(savedAlloc);
  3894.         NewHandleCanFail := h;
  3895.     end;
  3896.  
  3897. {****************************************************************************}
  3898. { ResizeHandleCanFail}
  3899. {}
  3900. {     Attempts to resize a handle without drawing upon the memory reserve.}
  3901. {     Raises an exception if the allocation fails.}
  3902. {}
  3903. {****************************************************************************}
  3904. procedure ResizeHandleCanFail (theHandle: univ Handle; newSize: Longint);
  3905.     var
  3906.         savedAlloc: Boolean;
  3907.     begin
  3908.         savedAlloc := SetAllocation(kAllocCanFail);
  3909.         SetHandleSize(theHandle, newSize);
  3910.         savedAlloc := SetAllocation(savedAlloc);
  3911.  
  3912.     { MemError now has error code, caller can FailMemError    }
  3913.     end;
  3914.  
  3915. {****************************************************************************}
  3916. { SetAllocation}
  3917. {}
  3918. {     Changes the parameters gApplication uses when the grow zone function is}
  3919. {     invoked. This happens when the Memory Mgr can't satisfy a requested}
  3920. {     memory allocation. This method also returns the previous setting, }
  3921. {     so you can do something like:}
  3922. {}
  3923. {         Boolean oldAlloc := SetAllocation( kAllocCanFail);}
  3924. {}
  3925. {             ...attempt something that could fail gracefully...}
  3926. {}
  3927. {         SetAllocation( oldAlloc);}
  3928. {}
  3929. {     If canFail is TRUE, this function does gApplication->RequestMemory( no loan, can fail)}
  3930. {     otherwise it does gApplication->RequestMemory( no loan, can't fail),}
  3931. {     i.e. this utility always sets loan approved FALSE.}
  3932. {}
  3933. {****************************************************************************}
  3934.  
  3935. function SetAllocation (canFail: Boolean): Boolean;
  3936.     var
  3937.         oldFail: Boolean;
  3938.     begin
  3939.         oldFail := gApplication.canFail;
  3940.         gApplication.RequestMemory(canFail);
  3941.         SetAllocation := oldFail;
  3942.     end;
  3943.  
  3944. {****************************************************************************}
  3945.  {SetCriticalOperation}
  3946.  
  3947.     {Changes the parameters gApplication uses when the grow zone function}
  3948.     {is called. If the application is in a critical operation, then more }
  3949.     {of the memory reserve is eligible to be released to satisfy a memory}
  3950.     {request.}
  3951. {****************************************************************************}
  3952. procedure SetCriticalOperation (aCriticalOp: Boolean);
  3953.     begin
  3954.         gApplication.SetCriticalOperation(aCriticalOp);
  3955.     end;
  3956.  
  3957. {****************************************************************************}
  3958. { ForgetHandle}
  3959. { }
  3960. {     If the handle isn't already NIL, it disposes of the handle and NILs it.}
  3961. {****************************************************************************}
  3962. procedure ForgetHandle (var h: univ Handle);
  3963.     var
  3964.         hndl: Handle;
  3965.     begin
  3966.         hndl := h;
  3967.         if (hndl <> nil) then
  3968.             begin
  3969.                 h := nil;
  3970.                 DisposeHandle(hndl);
  3971.             end;
  3972.     end;
  3973.  
  3974. {****************************************************************************}
  3975. { ForgetObject}
  3976. { }
  3977. {     If the object isn't already NIL, it sends it a Dispose message, then}
  3978. {     NILs it.}
  3979. {****************************************************************************}
  3980. procedure ForgetObject (var obj: univ CObject);
  3981.     var
  3982.         theObj: CObject;
  3983.     begin
  3984.         theObj := obj;
  3985.         if (theObj <> nil) then
  3986.             begin
  3987.                 obj := nil;
  3988.                 theObj.Free;
  3989.             end;
  3990.     end;
  3991.  
  3992. {****************************************************************************}
  3993. { ForgetPtr}
  3994. { }
  3995. {     If the pointer isn't already NIL, it disposes of the pointer and NILs it.}
  3996. {****************************************************************************}
  3997. procedure ForgetPtr (var p: univ Ptr);
  3998.     var
  3999.         thePtr: Ptr;
  4000.     begin
  4001.         thePtr := p;
  4002.         if (thePtr <> nil) then
  4003.             begin
  4004.                 p := nil;
  4005.                 DisposePtr(thePtr);
  4006.             end;
  4007.     end;
  4008.  
  4009. {****************************************************************************}
  4010. { ForgetResource}
  4011. { }
  4012. {      If the resource isn't already NIL, it releases and NILs it.}
  4013. {****************************************************************************}
  4014. procedure ForgetResource (var res: univ Handle);
  4015.     var
  4016.         theRes: Handle;
  4017.     begin
  4018.         theRes := res;
  4019.         if (theRes <> nil) then
  4020.             begin
  4021.                 res := nil;
  4022.                 ReleaseResource(theRes);
  4023.             end;
  4024.     end;
  4025.  
  4026. {****************************************************************************}
  4027. { SetMinimumStack}
  4028. { }
  4029. {      Sets the stack to at least minSize. Only call this once, as the very}
  4030. {    first statement in your program}
  4031. {****************************************************************************}
  4032.  
  4033. procedure SetMinimumStack (minSize: Longint);
  4034.     var
  4035.         defaultStack: LongIntPtr;
  4036.         newApplLimit: Longint;
  4037.     begin
  4038.         defaultStack := LongIntPtr(LMGetDefltStack);
  4039.         if (minSize > defaultStack^) then
  4040.             begin
  4041.                 newApplLimit := ord4(GetApplLimit) - (minSize - defaultStack^);
  4042.                 SetApplLimit(Ptr(newApplLimit));
  4043.             end;
  4044.     end;
  4045.  
  4046.  
  4047. {****************************************************************************}
  4048. { %_ALLOCOBJ}
  4049. { }
  4050. { Called by TCLRuntime.lib to allocate a handle for an object. This }
  4051. { routine attempts to allocate the handle without hitting into the    }
  4052. { toolbox memory reserve, and calls raises an exception if the        }
  4053. { allocation failed.                                                }
  4054. {****************************************************************************}
  4055.  
  4056. {$PUSH}
  4057. {$Z+}
  4058. function _ALLOCOBJ (objSize: Longint): Handle;
  4059.     var
  4060.         obj: Handle;
  4061.         savedAlloc: Boolean;
  4062.     begin
  4063.         if (gApplication <> nil) then
  4064.             begin
  4065.                 savedAlloc := SetAllocation(kAllocCanFail);
  4066.                 obj := NewHandleClear(objSize);
  4067.                 savedAlloc := SetAllocation(savedAlloc);
  4068.                 FailNIL(obj);
  4069.             end
  4070.         else
  4071.             obj := NewHandleClear(objSize);
  4072.  
  4073.         _ALLOCOBJ := obj;
  4074.     end;
  4075.  
  4076. {****************************************************************************}
  4077. { %_FAILEDDISPATCH}
  4078. { }
  4079. { Called by TCLRuntime.lib if an error was detected during method }
  4080. { dispatch. An error code of kBadObj means the object handle was  }
  4081. { NIL or odd. An error code of kLookupFailed means that a           }
  4082. { method with the given selector wasn't found. This may happen    }
  4083. { if you use a disposed or corrupted object.                      }
  4084. { All dispatch errors raise an exception.                          }
  4085. {****************************************************************************}
  4086.  
  4087. procedure _FAILEDDISPATCH (errCode: Integer);
  4088.     const
  4089.         kBadObj = 1;
  4090.         kLookupFailed = 2;
  4091.     begin
  4092.         if (errCode = kBadObj) then
  4093.             Failure(paramErr, excMsgNullObject)
  4094.         else if (errCode = kLookupFailed) then
  4095.             Failure(paramErr, excMsgLookupFailed)
  4096.         else
  4097.             Failure(errCode, 0);
  4098.     end;
  4099.  
  4100. {****************************************************************************}
  4101. { %_OBDISP}
  4102. { }
  4103. { Called by TCLRuntime.lib to dispose of an object handle    }
  4104. {****************************************************************************}
  4105.  
  4106. procedure _OBDISP (var obj: CObject);
  4107.     begin
  4108.         if (obj = nil) | odd(Longint(obj)) then
  4109.             Failure(excMsgNullObject, 0);
  4110.  
  4111.         DisposeHandle(Handle(obj));
  4112.         obj := nil;
  4113.     end;
  4114. {$POP}
  4115.  
  4116. {****************************************************************************}
  4117. { ForceNextPrepare}
  4118. {}
  4119. {        Clear cPreparedView to force the next Prepare to do a full Prepare.}
  4120. {****************************************************************************}
  4121. procedure ForceNextPrepare;
  4122.     begin
  4123.         cPreparedView := nil;
  4124.     end;
  4125.  
  4126.  
  4127. procedure ExitApplication;
  4128.     begin
  4129.         if (gApplication <> nil) then
  4130.             gApplication.ExitApp;
  4131.         ExitToShell;
  4132.     end;
  4133.  
  4134. function ApplicationIsRunning: Boolean;
  4135.     begin
  4136.         ApplicationIsRunning := (gApplication <> nil) & (gApplication.GetPhase = appRunning);
  4137.     end;
  4138.  
  4139. end.