/packages/fv/src/statuses.pas
Pascal | 1404 lines | 701 code | 107 blank | 596 comment | 43 complexity | 565dfe1f0d42ee9cf72e5324a8bb8735 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
1{$V-} 2unit Statuses; 3 4{$CODEPAGE cp437} 5 6{#Z+} 7{ Free Vision Status Objects Unit 8 Free VIsion 9 Written by : Brad Williams, DVM 10 11Revision History 12 131.2.3 (96/04/13) 14 - moved Pause and Resume to methods of TStatus leaving TStatus Pause and 15 Resume "aware" 16 - eliminated many bugs 17 - moved Pause, Resume and Cancel from TStatusDlg to TStatus 18 191.2.1 (95/12/6) 20 - minor typo corrections in opening unit documentation 21 - F+ to Z+ around stream registration records 22 - removed redundant sentence in TAppStatus definition 23 - updated CBarStatus documentation and constant 24 - removed TGauge.Init cross-reference from TSpinner.Init 25 - added THeapMemAvail and RegistertvStatus documentation 26 - numerous other documentation updates 27 - changed all calls to Send to Message 28 291.2.0 (95/11/24) 30 - conversion to Bsd format 31 321.1.0 (05/01/94) 33 - initial WVS release 34 35 36Known Bugs 37 38ScanHelp Errors 39 - sdXXXX constants help documentation doesn't show TStatusDlg and 40 TMessageStatusDlg 41 - ScanHelp produces garbage in evStatus help context 42 43tvStatus Bugs 44 - CAppStatus may not be correct } 45{#Z-} 46 47{ The tvStatus unit implements several views for providing information to 48the user which needs to be updated during program execution, such as a 49progress indicator, clock, heap viewer, gauges, etc. All tvStatus views 50respond to a new message event class, evStatus. An individual status view 51only processes an event with its associated command. } 52 53interface 54 55{$i platform.inc} 56 57{$ifdef PPC_FPC} 58 {$H-} 59{$else} 60 {$F+,O+,E+,N+} 61{$endif} 62{$X+,R-,I-,Q-,V-} 63{$ifndef OS_UNIX} 64 {$S-} 65{$endif} 66 67uses 68 69 FVCommon, FVConsts, Objects, Drivers, Views, Dialogs; 70{ Resource;} 71 72const 73 74 evStatus = $8000; 75 { evStatus represents the event class all status views know how to 76 respond to. } 77 {#X Statuses } 78 79 80 CStatus = #1#2#3; 81{$ifndef cdPrintDoc} 82{#F+} 83{�TStatus.CStatus palette 84�������������������������} 85{#F-} 86{$endif cdPrintDoc} 87{ Status views use the default palette, CStatus, to map onto the first three 88entries in the standard window palette. } 89{#F+} 90{ 1 2 3 91 ��������������ͻ 92 CStatus � 1 � 2 � 3 � 93 ��������������ͼ 94Normal Text���� � � 95Other��������������� � 96Highlighted Text��������� } 97{#F-} 98{#X TStatus } 99 100 CAppStatus = #2#5#4; 101{$ifndef cdPrintDoc} 102{#F+} 103{�TAppStatus.CAppStatus palette 104�������������������������������} 105{#F-} 106{$endif cdPrintDoc} 107{ Status views which are inserted into the application rather than a dialog 108or window use the default palette, CAppStatus, to map onto the application 109object's palette. } 110{#F+} 111{ 1 2 3 112 ��������������ͻ 113 CAppStatus � 2 � 5 � 4 � 114 ��������������ͼ 115Normal Text������� � � 116Other������������������ � 117Highlighted Text������������ } 118{#F-} 119 {#X tvStatus TAppStatus } 120 121 122 CBarGauge = CStatus + #16#19; 123{$ifndef cdPrintDoc} 124{#F+} 125{�TBarGauge.CBarGauge palette 126�����������������������������} 127{#F-} 128{$endif cdPrintDoc} 129{ TBarGauge's use the default palette, CBarGauge, to map onto the dialog or 130window owner's palette. } 131{#F+} 132{ 1 2 3 4 5 133 ������������������������ͻ 134 CAppStatus � 2 � 5 � 4 � 16 � 19 � 135 ������������������������ͼ 136Normal Text������� � � � ����� filled in bar 137Other������������������ � ���������� empty bar 138Highlighted Text������������ } 139{#F-} 140 {#X tvStatus TBarGauge } 141 142 143{#T sdXXXX } 144{$ifndef cdPrintDoc} 145{#F+} 146{������������������������������������ 147� sdXXXX constants (STDDLG unit) � 148������������������������������������} 149{#F-} 150{$endif cdNoPrintDoc} 151{ sdXXXX constants are used to determine the types of buttons displayed in a 152#TStatusDlg# or #TStatusMessageDlg#. } 153{#F+} 154{ Constant � Value � Meaning 155������������������������������������������������������������ 156 sdNone � $0000 � no buttons 157 sdCancelButton � $0001 � show Cancel button 158 sdPauseButton � $0002 � show Pause button 159 sdResumeButton � $0004 � show Resume button 160 sdAllButtons � $0008 � show Cancel, Pause and Resume 161 � � buttons } 162{#Z+} 163 sdNone = $0000; 164 sdCancelButton = $0001; 165 sdPauseButton = $0002; 166 sdResumeButton = $0004; 167 sdAllButtons = sdCancelButton or sdPauseButton or sdResumeButton; 168{#Z-} 169 {#X tvStatus TStatusDlg TStatusMessageDlg } 170 171 SpinChars : String[4] = '�/�\'; 172 { SpinChars are the characters used by a #TSpinnerGauge# when it is drawn. 173 Only one character is displayed at a time. The string is cycled 174 through then started over again until the view is disposed. } 175 {#X tvStatus } 176 177 sfPause = $F000; 178 { sfPause is an additional state flag used internally by status views to 179 indicate they are in a paused state and should not respond to their 180 command. } 181 182type 183 {#Z+} 184 PStatus = ^TStatus; 185 {#Z-} 186 TStatus = Object(TParamText) 187 { TStatus is the base object type from which all status views descend. 188 Status views are used to display information that will change at 189 run-time based upon some state or process in the application, such as 190 printing. 191 192 All status views that are to be inserted into the application should 193 descend from #TAppStatus# for proper color mapping. } 194 Command : Word; 195 { Command is the only command the status view will respond to. When 196 the status view receives an evStatus event it checks the value of the 197 Event.Command field against Command before handling the event. } 198 {#X HandleEvent } 199 constructor Init (R : TRect; ACommand : Word; AText : String; 200 AParamCount : Integer); 201 { Init calls the inherited constructor then sets #Command# to ACommand. 202 203 If an error occurs Init fails. } 204 {#X Load } 205 constructor Load (var S : TStream); 206 { Load calls the inherited constructor then reads #Command# from the 207 stream. 208 209 If an error occurs Load fails. } 210 {#X Store Init } 211 function Cancel : Boolean; virtual; 212 { Cancel should prompt the user when necessary for validation of 213 canceling the process which the status view is displaying. If the 214 user elects to continue the process Cancel must return False, 215 otherwise Cancel must return True. } 216 {#X Pause Resume } 217 function GetPalette : PPalette; virtual; 218 { GetPalette returns a pointer to the default status view palette, 219 #CStatus#. } 220 {#X TAppStatus CAppStatus } 221 procedure HandleEvent (var Event : TEvent); virtual; 222 { HandleEvent captures any #evStatus# messages with its command value 223 equal to #Command#, then calls #Update# with Data set to 224 Event.InfoPtr. If the State field has its #sfPause# bit set, the 225 view ignores the event. } 226 procedure Pause; virtual; 227 { Pause sends an evStatus message to the application with Event.Command 228 set to cmStatusPause and Event.InfoPtr set to #Status#^.Command. The 229 #Status# view's sfPause bit of the State flag is set by calling 230 SetState. In the paused state, the status view does not respond to 231 its associated command. } 232 {#X Resume sdXXXX Cancel } 233 procedure Reset; virtual; 234 { Reset causes the status view to be reset to its beginning or default 235 value, then be redrawn. Reset is used after an event is aborted 236 which can only be performed in its entirety. } 237 procedure Resume; virtual; 238 { Resume is called in response to pressing the Resume button. Resume 239 sends an evStatus message to the application with Event.Command set 240 to cmStatusPause and Event.InfoPtr set to #Status#^.Command. The 241 Status view's sfPause bit is turned off by calling SetState. } 242 {#X Pause sdXXXX Cancel } 243 procedure Store (var S : TStream); { store should never be virtual;} 244 { Store calls the inherited Store method then writes #Command# to the 245 stream. } 246 {#X Load } 247 procedure Update (Data : Pointer); virtual; 248 { Update changes the status' displayed text as necessary based on 249 Data. } 250 {#X Command HandleEvent } 251 end; { of TStatus } 252 253 254 {#Z+} 255 PStatusDlg = ^TStatusDlg; 256 {#Z-} 257 TStatusDlg = Object(TDialog) 258 { A TStatusDlg displays a status view and optional buttons. It may be 259 used to display any status message and optionally provide end user 260 cancelation or pausing of an ongoing operation, such as printing. 261 262 All status views that are to be inserted into a window or dialog should 263 descend from #TStatus# for proper color mapping. } 264 Status : PStatus; 265 { Status is the key status view for the dialog. When a cmStatusPause 266 command is broadcast in response to pressing the pause button, 267 Event.InfoPtr is set to point to the command associated with Status. } 268 {#X TStatus cmXXXX } 269 constructor Init (ATitle : TTitleStr; AStatus : PStatus; AFlags : Word); 270 { Init calls the inherited constructor to create the dialog and sets 271 the EventMask to handle #evStatus# events. AStatus is assigned to 272 #Status# and inserted into the dialog at position 2,2. 273 274 The dialog is anchored at AStatus^.Origin and its size is at least 275 AStatus^.Size + 2 in both dimensions. The actual size is determined 276 by the AFlags byte. The #sdXXXX# constants should be used to signify 277 which buttons to display. 278 279 If an error occurs Init fails. } 280 {#X TStatus.Pause TStatus.Resume } 281 constructor Load (var S : TStream); 282 { Load calls the inherited constructor then loads #Status#. 283 284 If an error occurs Load fails. } 285 {#X Store } 286 procedure Cancel (ACommand : Word); virtual; 287 { Cancel sends an evStatus message to the Application object with 288 command set to cmCancel and InfoPtr set to the calling status view's 289 command, then calls the inherited Cancel method. } 290 {#X TBSDDialog.Cancel } 291 procedure HandleEvent (var Event : TEvent); virtual; 292 { All evStatus events are accepted by the dialog and sent to each 293 subview in Z-order until cleared. 294 295 If the dialog recieves an evCommand or evBroadcast event with the 296 Command parameter set to cmCancel, HandleEvent sends an #evStatus# 297 message to the Application variable with Event.Command set to the 298 cmStatusCancel and Event.InfoPtr set to the #Status#.Command and 299 disposes of itself. 300 301 When a pause button is included, a cmStatusPause broadcast event is 302 associated with the button. When the button is pressed a call to 303 #TStatus.Pause# results. The status view is inactivated until it 304 receives an evStatus event with a commond of cmStatusResume and 305 Event.InfoPtr set to the status view's Command value. When a pause 306 button is used, the application should respond to the evStatus event 307 (with Event.Command of cmStatusPause) appropriately, then dispatch a 308 cmStatusResume evStatus event when ready to resume activity. } 309 {#X TStatus.Command } 310 procedure InsertButtons (AFlags : Word); virtual; 311 { InsertButtons enlarges the dialog to the necessary size and inserts 312 the buttons specified in AFlags into the last row of the dialog. } 313 procedure Store (var S : TStream); { store should never be virtual;} 314 { Store calls the inherited Store method then writes #Status# to the 315 stream. } 316 {#X Load } 317 end; { of TStatusDlg } 318 319 320 {#Z+} 321 PStatusMessageDlg = ^TStatusMessageDlg; 322 {#Z-} 323 TStatusMessageDlg = Object(TStatusDlg) 324 { A TStatusMessageDlg displays a message as static text with a status 325 view on the line below it. 326 327 All status views that are to be inserted into a window or dialog should 328 descend from #TStatus# for proper color mapping. } 329 constructor Init (ATitle : TTitleStr; AStatus : PStatus; AFlags : Word; 330 AMessage : String); 331 { Init calls the inherited constructor then inserts a TStaticText view 332 containing AMessage at the top line of the dialog. 333 334 The size of the dialog is determined by the size of the AStatus. The 335 dialog is anchored at AStatus^.Origin and is of at least 336 AStatus^.Size + 2 in heighth and width. The exact width and heighth 337 are determined by AOptions. 338 339 AFlags contains flags which determine the buttons to be displayed 340 in the dialog. 341 342 If an error occurs Init fails. } 343 end; { of TStatusMessageDlg } 344 345 346 {#Z+} 347 PGauge = ^TGauge; 348 {#Z-} 349 TGauge = Object(TStatus) 350 { A gauge is used to represent the current numerical position within a 351 range of values. When Current equals Max a gauge dispatches an 352 #evStatus# event with the command set to cmStatusDone to the 353 Application object. } 354 Min : LongInt; 355 { Min is the minimum value which #Current# may be set to. } 356 {#X Max } 357 Max : LongInt; 358 { Max is the maximum value which #Current# may be set to. } 359 {#X Min } 360 Current : LongInt; 361 { Current is the current value represented in the gauge. } 362 {#X Max Min } 363 constructor Init (R : TRect; ACommand : Word; AMin, AMax : LongInt); 364 { Init calls the inherited constructor then sets #Min# and #Max# to 365 AMin and AMax, respectively. #Current# is set to AMin. 366 367 If an error occurs Init fails. } 368 {#X Load } 369 constructor Load (var S : TStream); 370 { Load calls the inherited constructor then reads #Min#, #Max# and 371 #Current# from the stream. 372 373 If an error occurs Load fails. } 374 {#X Init Store } 375 procedure Draw; virtual; 376 { Draw writes the following to the screen: } 377{#F+} 378{ 379Min = XXX Max = XXX Current = XXX } 380{#F-} 381 { where XXX are the current values of the corresponding variables. } 382 procedure GetData (var Rec); virtual; 383 { GetData assumes Rec is a #TGaugeRec# and returns the current settings 384 of the gauge. } 385 {#X SetData } 386 procedure Reset; virtual; 387 { Reset sets #Current# to #Min# then redraws the status view. } 388 {#X TStatus.Reset } 389 procedure SetData (var Rec); virtual; 390 { SetData assumes Rec is a #TGaugeRec# and sets the gauge's variables 391 accordingly. } 392 {#X GetData } 393 procedure Store (var S : TStream); { store should never be virtual;} 394 { Store calls the inherited Store method then writes #Min#, #Max# and 395 #Current# to the stream. } 396 {#X Load } 397 procedure Update (Data : Pointer); virtual; 398 { Update increments #Current#. } 399 end; { of TGauge } 400 401 402 {#Z+} 403 PGaugeRec = ^TGaugeRec; 404 {#Z-} 405 TGaugeRec = record 406 { A TGaugeRec is used to set and get a #TGauge#'s variables. } 407 {#X TGauge.GetData TGauge.SetData } 408 Min, Max, Current : LongInt; 409 end; { of TGaugeRec } 410 411 412 {#Z+} 413 PArrowGauge = ^TArrowGauge; 414 {#Z-} 415 TArrowGauge = Object(TGauge) 416 { An arrow gauge draws a progressively larger series of arrows across the 417 view. If Right is True, the arrows are right facing, '>', and are 418 drawn from left to right. If Right is False, the arrows are left 419 facing, '<', and are drawn from right to left. } 420 Right : Boolean; 421 { Right determines the direction of arrow used and the direction which 422 the status view is filled. If Right is True, the arrows are right 423 facing, '>', and are drawn from left to right. If Right is False, 424 the arrows are left facing, '<', and are drawn from right to left. } 425 {#X Draw } 426 constructor Init (R : TRect; ACommand : Word; AMin, AMax : Word; 427 RightArrow : Boolean); 428 { Init calls the inherited constructor then sets #Right# to RightArrow. 429 430 If an error occurs Init fails. } 431 {#X Load } 432 constructor Load (var S : TStream); 433 { Load calls the inherited constructor then reads #Right# from the 434 stream. 435 436 If an error occurs Load fails. } 437 {#X Init Store } 438 procedure Draw; virtual; 439 { Draw fills the Current / Max percent of the view with arrows. } 440 {#X Right } 441 procedure GetData (var Rec); virtual; 442 { GetData assumes Rec is a #TArrowGaugeRec# and returns the current 443 settings of the views variables. } 444 {#X SetData } 445 procedure SetData (var Rec); virtual; 446 { SetData assumes Rec is a #TArrowGaugeRec# and sets the view's 447 variables accordingly. } 448 {#X GetData } 449 procedure Store (var S : TStream); { store should never be virtual;} 450 { Store calls the inherited Store method then writes #Right# to the 451 stream. } 452 {#X Load } 453 end; { of TArrowGauge } 454 455 456 {#Z+} 457 PArrowGaugeRec = ^TArrowGaugeRec; 458 {#Z-} 459 TArrowGaugeRec = record 460 { A TArrowGaugeRec is used to set and get the variables of a 461 #TArrowGauge#. } 462 {#X TArrowGauge.GetData TArrowGauge.SetData } 463 Min, Max, Count : LongInt; 464 Right : Boolean; 465 end; { of TGaugeRec } 466 467 468 {#Z+} 469 PPercentGauge = ^TPercentGauge; 470 {#Z-} 471 TPercentGauge = Object(TGauge) 472 { A TPercentGauge displays a numerical percentage as returned by 473 #Percent# followed by a '%' sign. } 474 function Percent : Integer; virtual; 475 { Percent returns the whole number value of (Current / Max) * 100. } 476 {#X TGauge.Current TGauge.Max } 477 procedure Draw; virtual; 478 { Draw writes the current percentage to the screen. } 479 {#X Percent } 480 end; { of TPercentGauge } 481 482 483 {#Z+} 484 PBarGauge = ^TBarGauge; 485 {#Z-} 486 TBarGauge = Object(TPercentGauge) 487 { A TBarGauge displays a bar which increases in size from the left to 488 the right of the view as Current increases. A numeric percentage 489 representing the value of (Current / Max) * 100 is displayed in the 490 center of the bar. } 491 {#x TPercentGauge.Percent } 492 procedure Draw; virtual; 493 { Draw draws the bar and percentage to the screen representing the 494 current status of the view's variables. } 495 {#X TGauge.Update } 496 function GetPalette : PPalette; virtual; 497 { GetPalette returns a pointer to the default status view palette, 498 #CBarStatus#. } 499 end; { of TBarGauge } 500 501 502 {#Z+} 503 PSpinnerGauge = ^TSpinnerGauge; 504 {#Z-} 505 TSpinnerGauge = Object(TGauge) 506 { A TSpinnerGauge displays a series of characters in one spot on the 507 screen giving the illusion of a spinning line. } 508 constructor Init (X, Y : Integer; ACommand : Word); 509 { Init calls the inherited constructor with AMin set to 0 and AMax set 510 to 4. } 511 procedure Draw; virtual; 512 { Draw uses the #SpinChars# variable to draw the view's Current 513 character. } 514 {#X Update } 515 procedure HandleEvent (var Event : TEvent); virtual; 516 { HandleEvent calls TStatus.HandleEvent so that a cmStatusDone event 517 is not generated when Current equals Max. } 518 {#X TGauge.Current TGauge.Max } 519 procedure Update (Data : Pointer); virtual; 520 { Update increments Current until Current equals Max, when it resets 521 Current to Min. } 522 {#X Draw HandleEvent } 523 end; { of TSpinnerGauge } 524 525 526 {#Z+} 527 PAppStatus = ^TAppStatus; 528 {#Z-} 529 TAppStatus = Object(TStatus) 530 { TAppStatus is a base object which implements color control for status 531 views that are normally inserted in the Application object. } 532 {#X TStatus } 533 function GetPalette : PPalette; virtual; 534 { GetPalette returns a pointer to the default application status view 535 palette, #CAppStatus#. } 536 {#X TStatus CStatus } 537 end; { of TAppStatus } 538 539 540 {#Z+} 541 PHeapMaxAvail = ^THeapMaxAvail; 542 {#Z-} 543 THeapMaxAvail = Object(TAppStatus) 544 { A THeapMaxAvail displays the largest available contiguous area of heap 545 memory. It responds to a cmStatusUpdate event by calling MaxAvail and 546 comparing the result to #Max#, then updating the view if necessary. } 547 {#X THeapMemAvail } 548 constructor Init (X, Y : Integer); 549 { Init creates the view with the following text: 550 551 MaxAvail = xxxx 552 553 where xxxx is the result returned by MaxAvail. } 554 procedure Update (Data : Pointer); virtual; 555 { Update changes #Mem# to the current MemAvail and redraws the status 556 if necessary. } 557 private 558 Max : LongInt; 559 { Max is the last reported value from MaxAvail. } 560 {#X Update } 561 end; { of THeapMaxAvail } 562 563 564 {#Z+} 565 PHeapMemAvail = ^THeapMemAvail; 566 {#Z-} 567 THeapMemAvail = Object(TAppStatus) 568 { A THeapMemAvail displays the total amount of heap memory available to 569 the application. It responds to a cmStatusUpdate event by calling 570 MemAvail and comparing the result to #Max#, then updating the view if 571 necessary. } 572 {#X THeapMaxAvail } 573 constructor Init (X, Y : Integer); 574 { Init creates the view with the following text: 575 576 MemAvail = xxxx 577 578 where xxxx is the result returned by MemAvail. } 579 {#X Load } 580 procedure Update (Data : Pointer); virtual; 581 { Update changes #Mem# to the current MemAvail and redraws the status 582 if necessary. } 583 private 584 Mem : LongInt; 585 { Mem is the last available value reported by MemAvail. } 586 {#X Update } 587 end; { of THeapMemAvail } 588 589 590{$ifndef cdPrintDoc} 591{#Z+} 592{$endif cdPrintDoc} 593const 594 RStatus : TStreamRec = ( 595 ObjType : idStatus; 596 VmtLink : Ofs(TypeOf(TStatus)^); 597 Load : @TStatus.Load; 598 Store : @TStatus.Store); 599 600 RStatusDlg : TStreamRec = ( 601 ObjType : idStatusDlg; 602 VmtLink : Ofs(TypeOf(TStatusDlg)^); 603 Load : @TStatusDlg.Load; 604 Store : @TStatusDlg.Store); 605 606 RStatusMessageDlg : TStreamRec = ( 607 ObjType : idStatusMessageDlg; 608 VmtLink : Ofs(TypeOf(TStatusMessageDlg)^); 609 Load : @TStatusMessageDlg.Load; 610 Store : @TStatusMessageDlg.Store); 611 612 RGauge : TStreamRec = ( 613 ObjType : idGauge; 614 VmtLink : Ofs(TypeOf(TGauge)^); 615 Load : @TGauge.Load; 616 Store : @TGauge.Store); 617 618 RArrowGauge : TStreamRec = ( 619 ObjType : idArrowGauge; 620 VmtLink : Ofs(TypeOf(TArrowGauge)^); 621 Load : @TArrowGauge.Load; 622 Store : @TArrowGauge.Store); 623 624 RBarGauge : TStreamRec = ( 625 ObjType : idBarGauge; 626 VmtLink : Ofs(TypeOf(TBarGauge)^); 627 Load : @TBarGauge.Load; 628 Store : @TBarGauge.Store); 629 630 RPercentGauge : TStreamRec = ( 631 ObjType : idPercentGauge; 632 VmtLink : Ofs(TypeOf(TPercentGauge)^); 633 Load : @TPercentGauge.Load; 634 Store : @TPercentGauge.Store); 635 636 RSpinnerGauge : TStreamRec = ( 637 ObjType : idSpinnerGauge; 638 VmtLink : Ofs(TypeOf(TSpinnerGauge)^); 639 Load : @TSpinnerGauge.Load; 640 Store : @TSpinnerGauge.Store); 641 642 RAppStatus : TStreamRec = ( 643 ObjType : idAppStatus; 644 VmtLink : Ofs(TypeOf(TAppStatus)^); 645 Load : @TAppStatus.Load; 646 Store : @TAppStatus.Store); 647 648 RHeapMinAvail : TStreamRec = ( 649 ObjType : idHeapMinAvail; 650 VmtLink : Ofs(TypeOf(THeapMaxAvail)^); 651 Load : @THeapMaxAvail.Load; 652 Store : @THeapMaxAvail.Store); 653 654 RHeapMemAvail : TStreamRec = ( 655 ObjType : idHeapMemAvail; 656 VmtLink : Ofs(TypeOf(THeapMemAvail)^); 657 Load : @THeapMemAvail.Load; 658 Store : @THeapMemAvail.Store); 659{$ifndef cdPrintDoc} 660{#Z-} 661{$endif cdPrintDoc} 662 663procedure RegisterStatuses; 664{$ifndef cdPrintDoc} 665{#F+} 666{���������������������������������������������� 667�RegisterStatuses procedure (Statuses unit)� 668����������������������������������������������} 669{#F-} 670{$endif cdPrintDoc} 671 { RegisterStatuses calls RegisterType for each of the status view and 672 status dialog object types defined in the tvStatus unit. After calling 673 RegisterStatuses, your application can read or write any of those types 674 with streams. } 675 676 677implementation 678 679uses 680 MsgBox, App; 681 682{****************************************************************************} 683{ Local procedures and functions } 684{****************************************************************************} 685 686{****************************************************************************} 687{ TAppStatus Object } 688{****************************************************************************} 689{****************************************************************************} 690{ TAppStatus.GetPalette } 691{****************************************************************************} 692function TAppStatus.GetPalette : PPalette; 693const P : String[Length(CAppStatus)] = CAppStatus; 694begin 695 GetPalette := PPalette(@P); 696end; 697 698{****************************************************************************} 699{ TArrowGauge Object } 700{****************************************************************************} 701{****************************************************************************} 702{ TArrowGauge.Init } 703{****************************************************************************} 704constructor TArrowGauge.Init (R : TRect; ACommand : Word; AMin, AMax : Word; 705 RightArrow : Boolean); 706begin 707 if not TGauge.Init(R,ACommand,AMin,AMax) then 708 Fail; 709 Right := RightArrow; 710end; 711 712{****************************************************************************} 713{ TArrowGauge.Load } 714{****************************************************************************} 715constructor TArrowGauge.Load (var S : TStream); 716begin 717 if not TGauge.Load(S) then 718 Fail; 719 S.Read(Right,SizeOf(Right)); 720 if (S.Status <> stOk) then 721 begin 722 TGauge.Done; 723 Fail; 724 end; 725end; 726 727{****************************************************************************} 728{ TArrowGauge.Draw } 729{****************************************************************************} 730procedure TArrowGauge.Draw; 731const Arrows : array[0..1] of Char = '<>'; 732var 733 B : TDrawBuffer; 734 C : Word; 735 Len : Byte; 736begin 737 C := GetColor(1); 738 Len := Round(Size.X * Current/(Max - Min)); 739 MoveChar(B,' ',C,Size.X); 740 if Right then 741 MoveChar(B,Arrows[Byte(Right)],C,Len) 742 else MoveChar(B[Size.X - Len],Arrows[Byte(Right)],C,Len); 743 WriteLine(0,0,Size.X,1,B); 744end; 745 746{****************************************************************************} 747{ TArrowGauge.GetData } 748{****************************************************************************} 749procedure TArrowGauge.GetData (var Rec); 750begin 751 PArrowGaugeRec(Rec)^.Min := Min; 752 PArrowGaugeRec(Rec)^.Max := Max; 753 PArrowGaugeRec(Rec)^.Count := Current; 754 PArrowGaugeRec(Rec)^.Right := Right; 755end; 756 757{****************************************************************************} 758{ TArrowGauge.SetData } 759{****************************************************************************} 760procedure TArrowGauge.SetData (var Rec); 761begin 762 Min := PArrowGaugeRec(Rec)^.Min; 763 Max := PArrowGaugeRec(Rec)^.Max; 764 Current := PArrowGaugeRec(Rec)^.Count; 765 Right := PArrowGaugeRec(Rec)^.Right; 766end; 767 768{****************************************************************************} 769{ TArrowGauge.Store } 770{****************************************************************************} 771procedure TArrowGauge.Store (var S : TStream); 772begin 773 TGauge.Store(S); 774 S.Write(Right,SizeOf(Right)); 775end; 776 777{****************************************************************************} 778{ TBarGauge Object } 779{****************************************************************************} 780{****************************************************************************} 781{ TBarGauge.Draw } 782{****************************************************************************} 783procedure TBarGauge.Draw; 784var 785 B : TDrawBuffer; 786 C : Word; 787 FillSize : Word; 788 PercentDone : LongInt; 789 S : String[4]; 790begin 791 { fill entire view } 792 MoveChar(B,' ',GetColor(4),Size.X); 793 { make progress bar } 794 C := GetColor(5); 795 FillSize := Round(Size.X * (Current / Max)); 796 MoveChar(B,' ',C,FillSize); 797 { display percent done } 798 PercentDone := Percent; 799 FormatStr(S,'%d%%',PercentDone); 800 if PercentDone < 50 then 801 C := GetColor(4); 802 FillSize := (Size.X - Length(S)) div 2; 803 MoveStr(B[FillSize],S,C); 804 WriteLine(0,0,Size.X,Size.Y,B); 805end; 806 807{****************************************************************************} 808{ TBarGauge.GetPalette } 809{****************************************************************************} 810function TBarGauge.GetPalette : PPalette; 811const 812 S : String[Length(CBarGauge)] = CBarGauge; 813begin 814 GetPalette := PPalette(@S); 815end; 816 817{****************************************************************************} 818{ TGauge Object } 819{****************************************************************************} 820{****************************************************************************} 821{ TGauge.Init } 822{****************************************************************************} 823constructor TGauge.Init (R : TRect; ACommand : Word; AMin, AMax : LongInt); 824begin 825 if not TStatus.Init(R,ACommand,'',1) then 826 Fail; 827 Min := AMin; 828 Max := AMax; 829 Current := Min; 830end; 831 832{****************************************************************************} 833{ TGauge.Load } 834{****************************************************************************} 835constructor TGauge.Load (var S : TStream); 836begin 837 if not TStatus.Load(S) then 838 Fail; 839 S.Read(Min,SizeOf(Min)); 840 S.Read(Max,SizeOf(Max)); 841 S.Read(Current,SizeOf(Current)); 842 if S.Status <> stOk then 843 begin 844 TStatus.Done; 845 Fail; 846 end; 847end; 848 849{****************************************************************************} 850{ TGauge.Draw } 851{****************************************************************************} 852procedure TGauge.Draw; 853var 854 S : String; 855 B : TDrawBuffer; 856begin 857 { Blank the gauge } 858 MoveChar(B,' ',GetColor(1),Size.X); 859 WriteBuf(0,0,Size.X,Size.Y,B); 860 { write current status } 861 FormatStr(S,'%d',Current); 862 MoveStr(B,S,GetColor(1)); 863 WriteBuf(0,0,Size.X,Size.Y,B); 864end; 865 866{****************************************************************************} 867{ TGauge.GetData } 868{****************************************************************************} 869procedure TGauge.GetData (var Rec); 870begin 871 TGaugeRec(Rec).Min := Min; 872 TGaugeRec(Rec).Max := Max; 873 TGaugeRec(Rec).Current := Current; 874end; 875 876{****************************************************************************} 877{ TGauge.Reset } 878{****************************************************************************} 879procedure TGauge.Reset; 880begin 881 Current := Min; 882 DrawView; 883end; 884 885{****************************************************************************} 886{ TGauge.SetData } 887{****************************************************************************} 888procedure TGauge.SetData (var Rec); 889begin 890 Min := TGaugeRec(Rec).Min; 891 Max := TGaugeRec(Rec).Max; 892 Current := TGaugeRec(Rec).Current; 893end; 894 895{****************************************************************************} 896{ TGauge.Store } 897{****************************************************************************} 898procedure TGauge.Store (var S : TStream); 899begin 900 TStatus.Store(S); 901 S.Write(Min,SizeOf(Min)); 902 S.Write(Max,SizeOf(Max)); 903 S.Write(Current,SizeOf(Current)); 904end; 905 906{****************************************************************************} 907{ TGauge.Update } 908{****************************************************************************} 909procedure TGauge.Update (Data : Pointer); 910begin 911 if Current < Max then 912 begin 913 Inc(Current); 914 DrawView; 915 end 916 else Message(@Self,evStatus,cmStatusDone,@Self); 917end; 918 919{****************************************************************************} 920{ THeapMaxAvail Object } 921{****************************************************************************} 922{****************************************************************************} 923{ THeapMaxAvail.Init } 924{****************************************************************************} 925constructor THeapMaxAvail.Init (X, Y : Integer); 926var 927 R : TRect; 928begin 929 R.Assign(X,Y,X+20,Y+1); 930 if not TAppStatus.Init(R,cmStatusUpdate,' MaxAvail = %d',1) then 931 Fail; 932 Max := -1; 933end; 934 935{****************************************************************************} 936{ THeapMaxAvail.Update } 937{****************************************************************************} 938procedure THeapMaxAvail.Update (Data : Pointer); 939var 940 M : LongInt; 941begin 942 M := MaxAvail; 943 if (Max <> M) then 944 begin 945 Max := MaxAvail; 946 SetData(Max); 947 end; 948end; 949 950{****************************************************************************} 951{ THeapMemAvail Object } 952{****************************************************************************} 953{****************************************************************************} 954{ THeapMemAvail.Init } 955{****************************************************************************} 956constructor THeapMemAvail.Init (X, Y : Integer); 957var 958 R : TRect; 959begin 960 R.Assign(X,Y,X+20,Y+1); 961 if not TAppStatus.Init(R,cmStatusUpdate,' MemAvail = %d',1) then 962 Fail; 963 Mem := -1; 964end; 965 966{****************************************************************************} 967{ THeapMemAvail.Update } 968{****************************************************************************} 969procedure THeapMemAvail.Update (Data : Pointer); 970 { Total bytes available on the heap. May not be contiguous. } 971var 972 M : LongInt; 973begin 974 M := MemAvail; 975 if (Mem <> M) then 976 begin 977 Mem := M; 978 SetData(Mem); 979 end; 980end; 981 982{****************************************************************************} 983{ TPercentGauge Object } 984{****************************************************************************} 985{****************************************************************************} 986{ TPercentGauge.Draw } 987{****************************************************************************} 988procedure TPercentGauge.Draw; 989var 990 B : TDrawBuffer; 991 C : Word; 992 S : String; 993 PercentDone : LongInt; 994 FillSize : Integer; 995begin 996 C := GetColor(1); 997 MoveChar(B,' ',C,Size.X); 998 WriteLine(0,0,Size.X,Size.Y,B); 999 PercentDone := Percent; 1000 FormatStr(S,'%d%%',PercentDone); 1001 MoveStr(B[(Size.X - Byte(S[0])) div 2],S,C); 1002 WriteLine(0,0,Size.X,Size.Y,B); 1003end; 1004 1005{****************************************************************************} 1006{ TPercentGauge.Percent } 1007{****************************************************************************} 1008function TPercentGauge.Percent : Integer; 1009 { Returns percent as a whole integer Current of Max } 1010begin 1011 Percent := Round((Current/Max) * 100); 1012end; 1013 1014{****************************************************************************} 1015{ TSpinnerGauge Object } 1016{****************************************************************************} 1017 1018{****************************************************************************} 1019{ TSpinnerGauge.Init } 1020{****************************************************************************} 1021constructor TSpinnerGauge.Init (X, Y : Integer; ACommand : Word); 1022var R : TRect; 1023begin 1024 R.Assign(X,Y,X+1,Y+1); 1025 if not TGauge.Init(R,ACommand,1,4) then 1026 Fail; 1027end; 1028 1029{****************************************************************************} 1030{ TSpinnerGauge.Draw } 1031{****************************************************************************} 1032procedure TSpinnerGauge.Draw; 1033var 1034 B : TDrawBuffer; 1035 C : Word; 1036begin 1037 C := GetColor(1); 1038 MoveChar(B,' ',C,Size.X); 1039 WriteLine(0,0,Size.X,Size.Y,B); 1040 MoveChar(B[Size.X div 2],SpinChars[Current],C,1); 1041 WriteLine(0,0,Size.X,Size.Y,B); 1042end; 1043 1044{****************************************************************************} 1045{ TSpinnerGauge.HandleEvent } 1046{****************************************************************************} 1047procedure TSpinnerGauge.HandleEvent (var Event : TEvent); 1048begin 1049 TStatus.HandleEvent(Event); 1050end; 1051 1052{****************************************************************************} 1053{ TSpinnerGauge.Update } 1054{****************************************************************************} 1055procedure TSpinnerGauge.Update (Data : Pointer); 1056begin 1057 if Current = Max then 1058 Current := Min 1059 else Inc(Current); 1060 DrawView; 1061end; 1062 1063{****************************************************************************} 1064{ TStatus Object } 1065{****************************************************************************} 1066{****************************************************************************} 1067{ TStatus.Init } 1068{****************************************************************************} 1069constructor TStatus.Init (R : TRect; ACommand : Word; AText : String; 1070 AParamCount : Integer); 1071begin 1072 if (not TParamText.Init(R,AText,AParamCount)) then 1073 Fail; 1074 EventMask := EventMask or evStatus; 1075 Command := ACommand; 1076end; 1077 1078{****************************************************************************} 1079{ TStatus.Load } 1080{****************************************************************************} 1081constructor TStatus.Load (var S : TStream); 1082begin 1083 if not TParamText.Load(S) then 1084 Fail; 1085 S.Read(Command,SizeOf(Command)); 1086 if (S.Status <> stOk) then 1087 begin 1088 TParamText.Done; 1089 Fail; 1090 end; 1091end; 1092 1093{****************************************************************************} 1094{ TStatus.Cancel } 1095{****************************************************************************} 1096function TStatus.Cancel : Boolean; 1097begin 1098 Cancel := True; 1099end; 1100 1101{****************************************************************************} 1102{ TStatus.GetPalette } 1103{****************************************************************************} 1104function TStatus.GetPalette : PPalette; 1105const 1106 P : String[Length(CStatus)] = CStatus; 1107begin 1108 GetPalette := PPalette(@P); 1109end; 1110 1111{****************************************************************************} 1112{ TStatus.HandleEvent } 1113{****************************************************************************} 1114procedure TStatus.HandleEvent (var Event : TEvent); 1115begin 1116 if (Event.What = evCommand) and (Event.Command = cmStatusPause) then 1117 begin 1118 Pause; 1119 ClearEvent(Event); 1120 end; 1121 case Event.What of 1122 evStatus : 1123 case Event.Command of 1124 cmStatusDone : 1125 if (Event.InfoPtr = @Self) then 1126 begin 1127 Message(Owner,evStatus,cmStatusDone,@Self); 1128 ClearEvent(Event); 1129 end; 1130 cmStatusUpdate : 1131 if (Event.InfoWord = Command) and ((State and sfPause) = 0) then 1132 begin 1133 Update(Event.InfoPtr); 1134 { ClearEvent(Event); } { don't clear the event so multiple } 1135 { status views can respond to the same event } 1136 end; 1137 cmStatusResume : 1138 if (Event.InfoWord = Command) and 1139 ((State and sfPause) = sfPause) then 1140 begin 1141 Resume; 1142 ClearEvent(Event); 1143 end; 1144 cmStatusPause : 1145 if (Event.InfoWord = Command) and ((State and sfPause) = 0) then 1146 begin 1147 Pause; 1148 ClearEvent(Event); 1149 end; 1150 end; 1151 end; 1152 TParamText.HandleEvent(Event); 1153end; 1154 1155{****************************************************************************} 1156{ TStatus.Pause } 1157{****************************************************************************} 1158procedure TStatus.Pause; 1159begin 1160 SetState(sfPause,True); 1161end; 1162 1163{****************************************************************************} 1164{ TStatus.Reset } 1165{****************************************************************************} 1166procedure TStatus.Reset; 1167begin 1168 DrawView; 1169end; 1170 1171{****************************************************************************} 1172{ TStatus.Resume } 1173{****************************************************************************} 1174procedure TStatus.Resume; 1175begin 1176 SetState(sfPause,False); 1177end; 1178 1179{****************************************************************************} 1180{ TStatus.Store } 1181{****************************************************************************} 1182procedure TStatus.Store (var S : TStream); 1183begin 1184 TParamText.Store(S); 1185 S.Write(Command,SizeOf(Command)); 1186end; 1187 1188{****************************************************************************} 1189{ TStatus.Update } 1190{****************************************************************************} 1191procedure TStatus.Update (Data : Pointer); 1192begin 1193 DisposeStr(Text); 1194 Text := NewStr(String(Data^)); 1195 DrawView; 1196end; 1197 1198{****************************************************************************} 1199{ TStatusDlg Object } 1200{****************************************************************************} 1201{****************************************************************************} 1202{ TStatusDlg.Init } 1203{****************************************************************************} 1204constructor TStatusDlg.Init (ATitle : TTitleStr; AStatus : PStatus; 1205 AFlags : Word); 1206var 1207 R : TRect; 1208 i : LongInt; 1209 Buttons : Byte; 1210begin 1211 if (AStatus = nil) then 1212 Fail; 1213 R.A := AStatus^.Origin; 1214 R.B := AStatus^.Size; 1215 Inc(R.B.Y,R.A.Y+4); 1216 Inc(R.B.X,R.A.X+5); 1217 if not TDialog.Init(R,ATitle) then 1218 Fail; 1219 EventMask := EventMask or evStatus; 1220 Status := AStatus; 1221 Status^.MoveTo(2,2); 1222 Insert(Status); 1223 InsertButtons(AFlags); 1224end; 1225 1226{****************************************************************************} 1227{ TStatusDlg.Load } 1228{****************************************************************************} 1229constructor TStatusDlg.Load (var S : TStream); 1230begin 1231 if not TDialog.Load(S) then 1232 Fail; 1233 GetSubViewPtr(S,Status); 1234 if (S.Status <> stOk) then 1235 begin 1236 if (Status <> nil) then 1237 Dispose(Status,Done); 1238 TDialog.Done; 1239 Fail; 1240 end; 1241end; 1242 1243{****************************************************************************} 1244{ TStatusDlg.Cancel } 1245{****************************************************************************} 1246procedure TStatusDlg.Cancel (ACommand : Word); 1247begin 1248 if Status^.Cancel then 1249 TDialog.Cancel(ACommand); 1250end; 1251 1252{****************************************************************************} 1253{ TStatusDlg.HandleEvent } 1254{****************************************************************************} 1255procedure TStatusDlg.HandleEvent (var Event : TEvent); 1256begin 1257 case Event.What of 1258 evStatus : 1259 case Event.Command of 1260 cmStatusDone : 1261 if Event.InfoPtr = Status then 1262 begin 1263 TDialog.Cancel(cmOk); 1264 ClearEvent(Event); 1265 end; 1266 end; 1267 { else let TDialog.HandleEvent send to all subviews for handling } 1268 evBroadcast, evCommand : 1269 case Event.Command of 1270 cmCancel, cmClose : 1271 begin 1272 Cancel(cmCancel); 1273 ClearEvent(Event); 1274 end; 1275 cmStatusPause : 1276 begin 1277 Status^.Pause; 1278 ClearEvent(Event); 1279 end; 1280 cmStatusResume : 1281 begin 1282 Status^.Resume; 1283 ClearEvent(Event); 1284 end; 1285 end; 1286 end; 1287 TDialog.HandleEvent(Event); 1288end; 1289 1290{****************************************************************************} 1291{ TStatusDlg.InsertButtons } 1292{****************************************************************************} 1293procedure TStatusDlg.InsertButtons (AFlags : Word); 1294var 1295 R : TRect; 1296 P : PButton; 1297 Buttons : Byte; 1298 X, Y, Gap : Integer; 1299 i : Word; 1300begin 1301 Buttons := Byte(((AFlags and sdCancelButton) = sdCancelButton)); 1302 { do this Inc twice, once for Pause and once for Resume buttons } 1303 Inc(Buttons,2 * Byte(((AFlags and sdPauseButton) = sdPauseButton))); 1304 if Buttons > 0 then 1305 begin 1306 Status^.GrowMode := gfGrowHiX; 1307 { resize dialog to hold all requested buttons } 1308 if Size.X < ((Buttons * 12) + 2) then 1309 GrowTo((Buttons * 12) + 2,Size.Y + 2) 1310 else GrowTo(Size.X,Size.Y + 2); 1311 { find correct starting position for first button } 1312 Gap := Size.X - (Buttons * 10) - 2; 1313 Gap := Gap div Succ(Buttons); 1314 X := Gap; 1315 if X < 2 then 1316 X := 2; 1317 Y := Size.Y - 3; 1318 { insert buttons } 1319 if ((AFlags and sdCancelButton) = sdCancelButton) then 1320 begin 1321 P := NewButton(X,Y,10,2,'Cancel',cmCancel,hcCancel,bfDefault); 1322 P^.GrowMode := gfGrowHiY or gfGrowLoY; 1323 Inc(X,12 + Gap); 1324 end; 1325 if ((AFlags and sdPauseButton) = sdPauseButton) then 1326 begin 1327 P := NewButton(X,Y,10,2,'~P~ause',cmStatusPause,hcStatusPause,bfNormal); 1328 P^.GrowMode := gfGrowHiY or gfGrowLoY; 1329 Inc(X,12 + Gap); 1330 P := NewButton(X,Y,10,2,'~R~esume',cmStatusResume,hcStatusResume, 1331 bfBroadcast); 1332 P^.GrowMode := gfGrowHiY or gfGrowLoY; 1333 end; 1334 end; { of if } 1335 SelectNext(False); 1336end; 1337 1338{****************************************************************************} 1339{ TStatusDlg.Store } 1340{****************************************************************************} 1341procedure TStatusDlg.Store (var S : TStream); 1342begin 1343 TDialog.Store(S); 1344 PutSubViewPtr(S,Status); 1345end; 1346 1347{****************************************************************************} 1348{ TStatusMessageDlg Object } 1349{****************************************************************************} 1350{****************************************************************************} 1351{ TStatusMessageDlg.Init } 1352{****************************************************************************} 1353constructor TStatusMessageDlg.Init (ATitle : TTitleStr; AStatus : PStatus; 1354 AFlags : Word; AMessage : String); 1355var 1356 P : PStaticText; 1357 X, Y : Integer; 1358 R : TRect; 1359begin 1360 if not TStatusDlg.Init(ATitle,AStatus,AFlags) then 1361 Fail; 1362 Status^.GrowMode := gfGrowLoY or gfGrowHiY; 1363 GetExtent(R); 1364 X := R.B.X - R.A.X; 1365 if X < Size.X then 1366 X := Size.X; 1367 Y := R.B.Y - R.A.Y; 1368 if Y < Size.Y then 1369 Y := Size.Y; 1370 GrowTo(X,Y); 1371 R.Assign(2,2,Size.X-2,Size.Y-3); 1372 P := New(PStaticText,Init(R,AMessage)); 1373 if (P = nil) then 1374 begin 1375 TStatusDlg.Done; 1376 Fail; 1377 end; 1378 GrowTo(Size.X,Size.Y + P^.Size.Y + 1); 1379 Insert(P); 1380end; 1381 1382{****************************************************************************} 1383{ Global procedures and functions } 1384{****************************************************************************} 1385 1386{****************************************************************************} 1387{ RegisterStatuses } 1388{****************************************************************************} 1389procedure RegisterStatuses; 1390begin 1391{ RegisterType(RStatus); 1392 RegisterType(RStatusDlg); 1393 RegisterType(RGauge); 1394 RegisterType(RArrowGauge); 1395 RegisterType(RPercentGauge); 1396 RegisterType(RBarGauge); 1397 RegisterType(RSpinnerGauge); } 1398end; 1399 1400{****************************************************************************} 1401{ Unit Initialization } 1402{****************************************************************************} 1403begin 1404end.